copying data from worksheet to another

[ashgull80]

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]

Posting a sample file shows how the data is laid out and makes a solution easier.

[Paul_Hossler]

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]

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]

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]

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]

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]

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]

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]

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]

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]

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]

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]

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]

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]

Hi thank you,
This doesnt seem to work even on the sample book?
Ash

[ashgull80]

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]

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]

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]

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