most efficient vba method to copy data from one sheet to another

Question

I am just trying a simple copy from one Excel sheet to another but the program seems to be taking forever.

n = WorksheetFunction.CountA(WAEnv.Range("a4:a" & WAEnv.Rows.Count))
ro = 3

For i = 4 To n + 4
    If Len(Trim(WAEnv.Cells(i, 1).Value)) > 0 Then
       ro = ro + 1
       WAPatch.Cells(ro, 1).RowHeight = WAEnv.Cells(i, 1).RowHeight
       WAPatch.Cells(ro, 1).Value = Trim(WAEnv.Cells(i, 1).Value)
       WAPatch.Cells(ro, 2).Value = Trim(WAEnv.Cells(i, 2).Value)
       WAPatch.Cells(ro, 3).Value = Trim(WAEnv.Cells(i, 3).Value)
       WAPatch.Cells(ro, 4).Value = Trim(WAEnv.Cells(i, 4).Value)
       WAPatch.Cells(ro, 5).Value = Trim(WAEnv.Cells(i, 5).Value)
    End If
Next i

Is there a faster or more efficient way to do this?

Answer 1

If objective to set RowHeight could be sacrificed, then may try the following code (obviously after modifying sheets, ranges particulars to your requirement)

Sub test()
Dim WAEnv As Worksheet, WAPatch As Worksheet, Rng As Range
Dim SrcArr As Variant, DstArr() As Variant
Dim Rw As Long, cl As Range
Dim Xrow As Long, Xcol As Long, Lastrow As Long
Dim Chunk60K As Long
Dim tm As Double
tm = Timer

Set WAEnv = ThisWorkbook.Sheets("Sheet3")
Set WAPatch = ThisWorkbook.Sheets("Sheet4")

Set Rng = WAEnv.Range("A4:E" & WAEnv.Cells(Rows.Count, 1).End(xlUp).Row)
SrcArr = Rng.Value
Xrow = 1
Chunk60K = 0

    For Rw = 1 To UBound(SrcArr, 1)
        If SrcArr(Rw, 1) > 0 Then
        ReDim Preserve DstArr(1 To 5, 1 To Xrow)
            For Xcol = 1 To 5
            DstArr(Xcol, Xrow) = SrcArr(Rw, Xcol)
            Next Xcol

            If Xrow = 60000 Then  ' To Overcome 65K limit of Application.Transpose
            WAPatch.Range("A" & Chunk60K * 60000 + 3).Resize(UBound(DstArr, 2), UBound(DstArr, 1)).Formula = Application.Transpose(DstArr)
            Chunk60K = Chunk60K + 1
            Xrow = 1
            ReDim DstArr(1 To 5, 1 To 1)
            Debug.Print "Chunk: " & Chunk60K & " Seconds Taken: " & Timer - tm
            Else
            Xrow = Xrow + 1
            End If

        End If
    Next Rw


WAPatch.Range("A" & Chunk60K * 60000 + 3).Resize(UBound(DstArr, 2), UBound(DstArr, 1)).Formula = Application.Transpose(DstArr)
Debug.Print "Completed at Chunk: " & Chunk60K & " Total Seconds Taken: " & Timer - tm

End Sub

Code takes around 7-8 seconds to process around 300 K rows (around 1/2 of it filtered out)

Since I personally don't prefer to keep calculations, event processing and screen updating off (in normal cases) i haven't added that standard lines. However you may use these standard techniques, depending on the working file condition.

Edit: adding code including Row height setting (unstable after 150 K)

Sub test4()
Dim WAEnv As Worksheet, WAPatch As Worksheet, Rng As Range
Dim SrcArr As Variant, DstArr() As Variant
Dim Rw As Long, cl As Range
Dim Xrow As Long, Xcol As Long, Lastrow As Long
Dim Chunk60K As Long
Dim tm As Double
tm = Timer


Set WAEnv = ThisWorkbook.Sheets("Sheet3")
Set WAPatch = ThisWorkbook.Sheets("Sheet4")
'n = WorksheetFunction.CountA(WAEnv.Range("a4:a" & WAEnv.Rows.Count))

Lastrow = WAEnv.Cells(Rows.Count, 1).End(xlUp).Row
Debug.Print Lastrow
Xrow = 1
Chunk60K = 0

        For Rw = 4 To Lastrow
        Set Rng = WAEnv.Range("A" & Rw & ":E" & Rw)
        If Rng(1, 1).Value > 0 Then
        ReDim Preserve DstArr(1 To 5, 1 To Xrow)
        Xcol = 1
            For Each cl In Rng.Columns.Cells
            DstArr(Xcol, Xrow) = cl.Value
            Xcol = Xcol + 1
            Next cl
        WAPatch.Cells(Xrow, 1).RowHeight = Rng(1, 1).RowHeight

            If Xrow = 60000 Then  ' To Overcome 65K limit of Application.Transpose
            WAPatch.Range("A" & Chunk60K * 60000 + 3).Resize(UBound(DstArr, 2), UBound(DstArr, 1)).Formula = Application.Transpose(DstArr)
            Chunk60K = Chunk60K + 1
            Xrow = 1
            ReDim DstArr(1 To 5, 1 To 1)
            Debug.Print "Chunk: " & Chunk60K & " Seconds Taken: " & Timer - tm
            Else
            Xrow = Xrow + 1
            End If
      End If
      Next Rw


WAPatch.Range("A" & Chunk60K * 60000 + 3).Resize(UBound(DstArr, 2), UBound(DstArr, 1)).Formula = Application.Transpose(DstArr)
Debug.Print "Completed at Chunk: " & Chunk60K & " Total Seconds Taken: " & Timer - tm

End Sub

Answer 2

n = WorksheetFunction.CountA(WAEnv.Range("a4:a" & WAEnv.Rows.Count))
ro = 3

For i = 4 To n + 4
    If Len(Trim(WAEnv.Cells(i, 1).Value)) > 0 Then
        ro = ro + 1
        WAEnv.range("A" & i & ":E" & i).copy
        WAPatch.range("A" & ro & ":E" & ro).pastespecial xlpastevalues
        With WAPatch.range("A" & ro & ":E" & ro)
            .Value = Evaluate("IF(ROW(" & .Address & "),CLEAN(TRIM(" & .Address & ")))")
        End With
    End if
Next

Copy and past the row of data in one go then trim the resulting data.

Also if you have a large number of formulas in the sheet it will slow down as it recalculates, if this is the case you can try setting calcs to manual at the start of your code and back to auto at the end.

Answer 3

I'd experiment with the times achieved without looping at all. Copy the entire sheet across, and then on the new sheet sort by one column descending to put your blanks to the bottom. If you care about the sort order then shrink your range and sort them again.

Admittedly that might not be quicker, but if you don't need the rows sorted as they originally were then you'll only need the one sort.

Finally, if you have a high proportion of blanks, and you're not coming back to the original sheet, do the sorting there before copying. Or apply a filter and delete the offending rows, though I find this a little more finicky.