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.

CodePudding user response：

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