PDA

View Full Version : copying data from worksheet to another



ashgull80
05-12-2017, 06:17 AM
Hi

I have a worksheet with a list of products with a quantity column, cost and total cost column.
what i would like to do is have a vba code that copies any product that has a number in the quantity box to another sheet.
i dont want the whole row copied just the product and quantity.
also i need to use the last row function as new products may be added each time.

i hope this makes sense and any help will be gratefully appreciated.

ash

mdmackillop
05-12-2017, 07:23 AM
Posting a sample file shows how the data is laid out and makes a solution easier.

Paul_Hossler
05-12-2017, 07:34 AM
Assuming that your data looks like Sheet1 in the attachment, try this. Otherwise, you'll have to adjust things

It's usually much easier to help with these sort of questions if you can provide a sample workbook with enough representative data to show




Option Explicit
Sub CopyQtys()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim r1 As Range, r2 As Range

Application.ScreenUpdating = False

Set ws1 = Worksheets("Sheet1")

On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Qty").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Worksheets.Add.Name = "Qty"
Set ws2 = Worksheets("Qty")

Set r1 = ws1.Cells(1, 1).CurrentRegion
Set r1 = r1.Resize(, 2)

r1.Copy

ws2.Select
ws2.Cells(1, 1).Select

Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Set r2 = ws2.Cells(1, 1).CurrentRegion
On Error Resume Next
r2.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

Application.ScreenUpdating = True
End Sub

ashgull80
05-12-2017, 08:10 AM
Hi

I have made a small sample workbook as it will hopefully be easier for everyone.
id like the job with a quantity in the box transferred to sheet 2 when the button is pressed.

thanks ash

mdmackillop
05-12-2017, 09:14 AM
as it will hopefully be easier for everyone
What would be easier is to lose the merged cells. These make coding more complicated and in this case seem to add nothing. If you need a wider header, use "Centre across Selection"

ashgull80
05-12-2017, 09:30 AM
yes this is no issue, how will the code work for what i require though?
or would you like me to alter that sheet first?
thanks

mdmackillop
05-12-2017, 10:14 AM
Adjust for unmerged columns as required

Sub Test()
Dim r As Range
Set r = Sheets("Sheet1").Range("A1").CurrentRegion
r.Columns(4).AutoFilter Field:=1, Criteria1:=">0"
Set r = r.Offset(1).Resize(r.Rows.Count - 2)
r.Columns(1).Copy Sheets("Sheet2").Range("A2")
r.Columns(4).Copy Sheets("Sheet2").Range("B2")
r.Columns(4).AutoFilter
End Sub

Paul_Hossler
05-12-2017, 11:44 AM
This is with the Sheet1 cells unmerged (demerged?) and Col B deleted since it was empty and not needed



Private Sub CommandButton1_Click()

Application.ScreenUpdating = False

Worksheets("Sheet1").Cells(1, 1).CurrentRegion.Copy
With Worksheets("Sheet2")
.Select
.Cells(1, 1).Select
.Paste
.Columns(4).Delete
.Columns(2).Delete
On Error Resume Next
.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

.Columns(2).EntireColumn.AutoFit
.Columns(1).EntireColumn.AutoFit

End With

Application.ScreenUpdating = True
End Sub

ashgull80
05-13-2017, 02:55 AM
This is great Paul thank you.
is there any way it only transfers the info in the cell as apposed to copying so it doesn't copy the format and colour of the cells ect?
Thanks again Ash

Paul_Hossler
05-13-2017, 06:32 AM
is there any way it only transfers the info in the cell as apposed to copying so it doesn't copy the format and colour of the cells etct?


.PasteSpecial instead of .Paste




Private Sub CommandButton1_Click()

Application.ScreenUpdating = False

Worksheets("Sheet1").Cells(1, 1).CurrentRegion.Copy
With Worksheets("Sheet2")
.Select
.Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Columns(4).Delete
.Columns(2).Delete
On Error Resume Next
.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

.Columns(2).EntireColumn.AutoFit
.Columns(1).EntireColumn.AutoFit

End With

Application.ScreenUpdating = True

End Sub

rlv
05-13-2017, 07:34 AM
Using autofilter


Private Sub CommandButton1_Click()
CopyInfo
End Sub

Sub CopyInfo()
Application.ScreenUpdating = False
Worksheets("Sheet2").UsedRange.ClearContents
With Worksheets("Sheet1")
If .AutoFilterMode Then
.AutoFilterMode = False
End If

.Columns.AutoFilter Field:=Me.Columns("D").Column, Criteria1:="<>"
.Columns("C:C").Hidden = True
.Columns("E:E").Hidden = True
.UsedRange.SpecialCells(xlCellTypeVisible).Copy

With Worksheets("Sheet2")
.Range("A1").PasteSpecial Paste:=xlPasteValues
.Columns(2).Delete
.Columns.AutoFit
End With

.AutoFilterMode = False
.UsedRange.Columns.Hidden = False
.UsedRange.Rows.Hidden = False
End With
Application.ScreenUpdating = True
End Sub

ashgull80
05-13-2017, 03:38 PM
Thanks all for your help but im having issues with all ideas.
i have made an adjustment to the sample book as ive noted on sheet 2 where i would like the pasting to start.
also id like a range (B12:B22 H12:H22) on sheet 2 cleared before pasting rather than the whole sheet, is this possible?

rlv
05-13-2017, 05:30 PM
Your explanation of how you want the sheet2 data to look is not clear to me. I recommend that you take your sample workbook and manually edit sheet2 to arrange the copied data exactly as you want VBA to do it , and then post it here.

ashgull80
05-15-2017, 12:18 PM
Hi
Sorry was getting late at night.
i have altered the sample book now so hopefully it makes sense now, need the table on sheet 2 cleared before transferring the new data.
Thank you, Ash

Paul_Hossler
05-15-2017, 05:25 PM
Try something like this




Private Sub CommandButton1_Click()
Dim r1 As Range, r2 As Range

Application.ScreenUpdating = False

Worksheets("Sheet2").Select

Set r2 = Worksheets("Sheet2").Cells(11, 2).CurrentRegion
If r2.Rows.Count > 1 Then
r2.Cells(2, 1).Resize(r2.Rows.Count - 1, r2.Columns.Count).Clear
End If

Set r1 = Worksheets("Sheet1").Cells(2, 2).CurrentRegion
Set r1 = r1.Cells(2, 1).Resize(r1.Rows.Count - 2, 2)
r1.Copy

Worksheets("Sheet2").Cells(12, 2).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False


On Error Resume Next
r2.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

r2.Columns(2).EntireColumn.AutoFit
r2.Columns(1).EntireColumn.AutoFit

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

ashgull80
05-16-2017, 01:18 PM
Hi thank you,
This doesnt seem to work even on the sample book?
Ash

ashgull80
05-16-2017, 02:51 PM
Hi
Im now using this code
My question is how can i install the copied info into row 7 instead of row 2?


Private Sub CommandButton1_Click()

Dim pjWs As Worksheet, ws As Worksheet, i As Long, lr As Long
Set pjWs = Worksheets("Project")
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Project" Then
With ws
lr = .Cells(.Rows.Count, 2).End(xlUp).Row
For i = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row - 1
If .Cells(i, 3).Value > 0 Then pjWs.Cells(Rows.Count, 10).End(xlUp).Offset(1).Resize(, 2).Value = .Cells(i, 2).Resize(, 2).Value
Next i

End With
End If
Next ws


End Sub

Paul_Hossler
05-16-2017, 04:32 PM
I moved too many lines to clear the existing data first




Private Sub CommandButton1_Click()
Dim r1 As Range, r2 As Range
Application.ScreenUpdating = False

Worksheets("Sheet2").Select

Set r2 = Worksheets("Sheet2").Cells(11, 2).CurrentRegion
If r2.Rows.Count > 1 Then
r2.Cells(2, 1).Resize(r2.Rows.Count - 1, r2.Columns.Count).Clear
End If

Set r1 = Worksheets("Sheet1").Cells(2, 2).CurrentRegion
Set r1 = r1.Cells(2, 1).Resize(r1.Rows.Count - 2, 2)
r1.Copy

Worksheets("Sheet2").Cells(12, 2).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False


Set r2 = Worksheets("Sheet2").Cells(11, 2).CurrentRegion ' added
On Error Resume Next
r2.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

r2.Columns(2).EntireColumn.AutoFit
r2.Columns(1).EntireColumn.AutoFit

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

ashgull80
05-17-2017, 02:36 PM
Hi Paul

Thank you this works well.
i would still like my previous question answered #17 if possible as its bugging me.
Thanks Ash

Paul_Hossler
05-17-2017, 03:04 PM
My question is how can i install the copied info into row 7 instead of row 2?


Do you mean 12, since that was the row in your example






Private Sub CommandButton1_Click()
Dim r1 As Range, r2 As Range
Application.ScreenUpdating = False

Worksheets("Sheet2").Select

Set r2 = Worksheets("Sheet2").Cells(7, 2).CurrentRegion
If r2.Rows.Count > 1 Then
r2.Cells(2, 1).Resize(r2.Rows.Count - 1, r2.Columns.Count).Clear
End If

Set r1 = Worksheets("Sheet1").Cells(2, 2).CurrentRegion
Set r1 = r1.Cells(2, 1).Resize(r1.Rows.Count - 2, 2)
r1.Copy

Worksheets("Sheet2").Cells(7, 2).Select ' <<<<<<<<< was (12, 2)
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Set r2 = Worksheets("Sheet2").Cells(7, 2).CurrentRegion ' added
On Error Resume Next
r2.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

r2.Columns(2).EntireColumn.AutoFit
r2.Columns(1).EntireColumn.AutoFit

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub