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

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.