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?

Filter and then copy visible cells perhaps instead of going line by line. — BigBen
– BigBen, Commented Jul 3, 2019 at 23:17
Your If statement should theoretically exclude rows, depending on your data, so I'm not sure what you mean by that. You could also read the data into a variant array and manipulate it there, then write to the other worksheet in one step. Repeatedly reading from/writing to a sheet is slow. — BigBen
– BigBen, Commented Jul 3, 2019 at 23:31
Yep agree, I am looking to see if the first column of each row has data , if yes , then proceeding with the copying — misguided
– misguided, Commented Jul 3, 2019 at 23:34

Ahmed AU · Accepted Answer · 2019-07-04 04:21:07Z

2

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

edited Jul 4, 2019 at 4:21

answered Jul 4, 2019 at 3:30

Ahmed AU

2,7772 gold badges9 silver badges15 bronze badges

Sign up to request clarification or add additional context in comments.

5 Comments

misguided Over a year ago

Is there a way we can copy over formatting with the above code as well? This works heaps faster than the previous code. Almost instantaneously copying rows.

Ahmed AU Over a year ago

before posting I tried with 150 K rows and Row height setting. and it worked at around 10 minutes. but when tried with 300 k it is becoming unstable. If your requirement is below 150 K row I would be happy to share that code.

Ahmed AU Over a year ago

Sorry i skipped trimming in your code. May use DstArr(Xcol, Xrow) = Trim(SrcArr(Rw, Xcol))

misguided Over a year ago

requirement is much less than that . Max 10k rows.

Ahmed AU Over a year ago

Edit Code with 2nd option, May pl feedback

Dan Donoghue · Accepted Answer · 2019-07-03 23:31:55Z

0

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.

edited Jul 3, 2019 at 23:31

answered Jul 3, 2019 at 23:26

Dan Donoghue

6,2662 gold badges20 silver badges36 bronze badges

3 Comments

misguided Over a year ago

I tried the code above, this seems to be executing slower than the initial code.

Dan Donoghue Over a year ago

Did you turn calculations off?

misguided Over a year ago

the sheet doesn't have any formulas currently

SamP · Accepted Answer · 2019-07-04 02:25:46Z

0

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.

answered Jul 4, 2019 at 2:25

SamP

1861 gold badge2 silver badges10 bronze badges

Collectives™ on Stack Overflow

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

3 Answers 3

5 Comments

3 Comments

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

5 Comments

3 Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Related