Vba copy paste slows with more records

Robert Bluszcz 0
Viewed 45

I'm trying to help someone who has to go through 80k rows on excel between two sheets and identify differences and then load the changed records into a database.

The below code works but slows down significantly with bigger data set, at 10k rows it takes 00:02:22 but with 20k it takes 00:10:13, full 80k rows takes under 2 hours which is still a lot faster than someone doing it manually over a day but I hoping someone can tell me what can potentially be impacting the performance with a higher number of records and how I can solve it?

Sub Button1_Click()

'Option Explicit
Application.ScreenUpdating = False
Application.EnableEvents = False

Set Day1_Sheet = ThisWorkbook.Sheets("Day1")
Set Day2_Sheet = ThisWorkbook.Sheets("Day2")
Set VBA_Export = ThisWorkbook.Sheets("VBA_Export")

Dim Day1Code, Day2Code As String
Dim Day1CodeRow As Long, Day2CodeRow As Long, CurrentRow As Long, CurrentColumn As Long, AccountsN As Long, n As Long
Dim LastEmptyColumnResult As Long, LastEmptyRowResult As Long
Dim BolUpdated As Boolean
Dim cTime, eTime As Variant

Day1_Sheet_Rows = Day1_Sheet.Cells(Rows.Count, "B").End(xlUp).Row
Day2_Sheet_Rows = Day2_Sheet.Cells(Rows.Count, "B").End(xlUp).Row

LastEmptyColumnResult = 4
LastEmptyRowResult = 2
BolUpdated = False

VBA_Export.Range("A2:E10000").Clear

cTime = Now()

For Each c In Day1_Sheet.Range("B2:B" & Day1_Sheet_Rows)

    BolUpdated = False

    Day1Code = c

    For Each e In Day2_Sheet.Range("B2:B" & Day2_Sheet_Rows)
    
        If c = e Then
        
            Day2Code = e
            Day2CodeRow = e.Row
            CurrentRow = c.Row
            Exit For
            
        End If
    
    Next e

    CurrentColumn = 3
    
    While CurrentColumn <> 17
    
        If Day1_Sheet.Cells(CurrentRow, CurrentColumn).Value = Day2_Sheet.Cells(Day2CodeRow, CurrentColumn).Value Then
    
        Else
            
            If BolUpdated Then
            Else
            
            Day2_Sheet.Rows(Day2CodeRow).EntireRow.Copy VBA_Export.Range("A" & LastEmptyRowResult)
          
            LastEmptyRowResult = LastEmptyRowResult + 1
            
            BolUpdated = True
            
            End If
            
        End If
        
        CurrentColumn = CurrentColumn + 1
        
    Wend

Next c

LastLine:

Set Day1_Sheet = Nothing
Set Day2_Sheet = Nothing

eTime = Now()

MsgBox ("Start Time " & cTime & ".End Time " & eTime)

Debug.Print "Elapsed Time " & eTime - cTime

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
vba excel
1 Answers

See below for suggestions for speeding up your process - basically do everything you can using arrays and avoid cell-by-cell access.

Sub Button1_Click()
    Const NUM_COLS As Long = 16 'number of columns in your datasets
    Dim Day1_Sheet As Worksheet, Day2_Sheet As Worksheet, VBA_Export As Worksheet
    Dim data1, data2, destRow As Long, changed As Boolean, rw1 As Long, rw2 As Variant
    Dim col As Long, cTime, eTime
    
    Set Day1_Sheet = ThisWorkbook.Sheets("Day1")
    Set Day2_Sheet = ThisWorkbook.Sheets("Day2")
    Set VBA_Export = ThisWorkbook.Sheets("VBA_Export")
    
    'load both datasets into arrays for faster access
    data1 = Day1_Sheet.Range("A1").Resize(Day1_Sheet.Cells(Rows.Count, "B").End(xlUp).Row, NUM_COLS).Value
    data2 = Day2_Sheet.Range("A1").Resize(Day2_Sheet.Cells(Rows.Count, "B").End(xlUp).Row, NUM_COLS).Value
    
    VBA_Export.Range("A2:E10000").Clear
    destRow = 2
    
    cTime = Now()
    GoFast   'turn on speed enhancements
    For rw1 = 2 To UBound(data1, 1)  'loop over Day1 data
        'try to match on colB - using Match on the worksheet is quite fast
        rw2 = Application.Match(data1(rw1, 2), Day2_Sheet.Columns("B"), 0) 'find matching row...
        If Not IsError(rw2) Then         'got a match on Day2 ?
            changed = False              'reset flag
            For col = 3 To NUM_COLS      'loop over columns
                If data1(rw1, col) <> data2(rw2, col) Then
                    changed = True       'flag row as changed
                    Exit For             'no need to check further
                End If
            Next col
            If changed Then              'Day2 is different?
                Day2_Sheet.Rows(rw2).Copy VBA_Export.Cells(destRow, "A")
                destRow = destRow + 1    'next paste row
            End If
        Else
            'no Col B match was found. Do something?
        End If
    Next rw1
    GoFast False 'turn off speed enhancements
    
    eTime = Now()
    MsgBox ("Start Time " & cTime & ".End Time " & eTime)
    Debug.Print "Elapsed Time " & eTime - cTime
    
End Sub

'maximize code speed by turning off unneeded stuff
'******** must reset !!!!
Sub GoFast(Optional bYesNo As Boolean = True)
  With Application
      .ScreenUpdating = Not bYesNo
      .Calculation = IIf(bYesNo, xlCalculationManual, xlCalculationAutomatic)
  End With
End Sub
useryB020
Related