Speed up and simplify

Question

I cobbled together something that does work for me as is, but it runs very slowly and I'm sure the code can be simplified.


Sub CopyPasteValues()

Dim strSht1, strSht2 As String
Dim c, rng As Range

strSht1 = "Edit"
strSht2 = "LOB"


With ThisWorkbook.Sheets(strSht1)
Set rng = Range("J2:AJ37")

    For Each c In rng
       If Not c.Value = 0 Then
       Cells(c.Row, 2).Copy
         ThisWorkbook.Sheets(strSht2).Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
       Range(Cells(c.Row, 4), Cells(c.Row, 5)).Copy
         ThisWorkbook.Sheets(strSht2).Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
       c.Copy
         ThisWorkbook.Sheets(strSht2).Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
       Cells(c.Column).Copy
         ThisWorkbook.Sheets(strSht2).Range("G" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End If
     Next c
End With
End Sub

I appreciate any assistance.

Cameron Critchlow · Answer

As BigBen Mentioned, array method. Super Fast.

Sub Move_Values_Array_Method()

    Dim SourceSheet As Worksheet        'Source Worksheet
    Dim DestinationSheet As Worksheet   'Destination Worksheet
    Dim RG As Range                     'Source Range
    Dim InArr()                         'Data In Array
    Dim OutArr()                        'Data Out Array
    Dim X As Long                       'Array X Position for purposes of iterating through array.
    Dim Y As Long                       'Array Y Position for purposes of iterating through array.
    Dim Cnt As Long                     'Found Value Count
    
    Set SourceSheet = ThisWorkbook.Worksheets("Edit")       'Set Source Worksheet
    Set DestinationSheet = ThisWorkbook.Worksheets("LOB")   'Set Dest Worksheet
    Set RG = SourceSheet.Range("J2:AJ37")                   'Set Source Range
    ReDim OutArr(1 To RG.Cells.Count)                       'Count Cells in Range, resize output array to be at least that big.
    InArr = RG                                              'Transfer Range Data to Array
    Cnt = 0
    
    Debug.Print LBound(InArr, 1) & " - " & UBound(InArr, 1) 'Rows
    Debug.Print LBound(InArr, 2) & " - " & UBound(InArr, 2) 'Columns
    
    For Y = 1 To UBound(InArr, 1)           'For Each Row in Array (or each Y position)
        For X = 1 To UBound(InArr, 2)       'For Each Column in Array (or each X position)
            If InArr(Y, X) <> "" Then       'If not blank Value (you can change this to "If InArr(Y, X) <> 0 Then" if that works best for you.
                Cnt = Cnt + 1               'Increment "found value count" by 1
                OutArr(Cnt) = InArr(Y, X)   'Add found value to output array
            End If
        Next X
    Next Y
    
    'Output to Dest Sheet
    DestinationSheet.Range("F2").Resize(UBound(OutArr, 1), 1).Value = Application.Transpose(OutArr())
    
End Sub

Cameron Critchlow · Answer

Based on the information in your previous comments, try these alternative solution using formulas and filters...

1) Array Formulas

To note:

I have put everything on one sheet for clarity, but it works just as well over multiple sheets, or even workbooks.
If you want to filter the entire sheet, with same column order, you only need to enter formula once and expand "Array" criteria in formula to encapsulate entire data set.

Formula used in cell "J4" = "=FILTER($I$4:$I$30,$C$4:$C$30>0)"
(filter range I4 to I30 to show rows where value in range C4 to C30 is greater than 0)

2) Directly Filter

Alternatively, you could (either manually or programmatically) copy all data to LOB sheet, (or selectively copy), then filter for Qty>0.

Speed up and simplify

2 Answers