Speeding up for cycle-CodePudding

Hy to everyone, I'm quite new in VBA word, btw i wrote a little code to copy some rows from one worksheet to another when the strings in the first columns of the two sheets match. The problem is that I'm looping on a = 16 rows and j = 15000 rows, so the code is really slow. I did a test with j = 1000 to have a reference time equal to 20 s.

Do you have some suggestions to speed the code up ? TY.

Dim ws As Worksheet
Dim ws2 As Worksheet
Set ws = Worksheets("Calcoli")
Set ws2 = Worksheets("Anagrafica")

Dim a As Long
Dim j As Long

Last_calcoli = ws.Cells(Rows.Count, 1).End(xlUp).Row
Last_anagrafica = ws2.Cells(Rows.Count, 1).End(xlUp).Row
T0 = Timer

ScreenUpdateState = Application.ScreenUpdating
StatusBarState = Application.DisplayStatusBar
CalcState = Application.Calculation
EventsState = Application.EnableEvents
DisplayPageBreakState = ActiveSheet.DisplayPageBreaks
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False


    For a = 2 To Last_anagrafica
    MyString2 = Worksheets("Anagrafica").Cells(a, 1)
    
        For j = 2 To 1000  'in faster version update 1000 to Last_calcoli
        Compare2 = Worksheets("Calcoli").Cells(j, 1)
            If MyString2 = Compare2 Then
            ws2.Range("B" & a & ":D" & a).Copy 'original range
            ws.Range("W" & j & ":Y" & j).PasteSpecial 'destination range
            End If
            
        Next j
        
    Next a
         
         
Application.ScreenUpdating = ScreenUpdateState
Application.DisplayStatusBar = StatusBarState
Application.Calculation = CalcState
Application.EnableEvents = EventsState
ActiveSheet.DisplayPageBreaks = DisplayPageBreaksState
        
InputBox "The runtime of this program is", "Runtime", Timer - T0
End Sub

CodePudding user response：

Excel VBA Performance Suggestions:

Instead of a double loop iterating over cells in ranges, load the data into arrays.
Put the Anagrafica data into a dictionary to speed up comparisons, and then use that to update the Calcoli data.
Output the results all at once at the end instead of one at a time as encountered.

Here's your code refactored with those things in mind. I have added comments to help with readability:

Sub tgr()
    
    'Start timer
    Dim dTimer As Double:   dTimer = Timer
    
    On Error GoTo CleanExit 'If error is encountered anywhere, cleanly exit the sub and re-enable appstates
    
    'Declare and set workbook, worksheet, and range variables
    Dim wb As Workbook:     Set wb = ActiveWorkbook
    Dim wsCal As Worksheet: Set wsCal = wb.Worksheets("Calcoli")
    Dim rCal As Range:      Set rCal = wsCal.Range("A2", wsCal.Cells(wsCal.Rows.Count, "A").End(xlUp))
    Dim wsAna As Worksheet: Set wsAna = wb.Worksheets("Anagrafica")
    Dim rAna As Range:      Set rAna = wsAna.Range("A2", wsAna.Cells(wsAna.Rows.Count, "A").End(xlUp))
    If rCal.Row < 2 Or rAna.Row < 2 Then Exit Sub  'No data
    
    DisableAppStates        'Disable app states
    
    'Declare and assign array variables (much faster to work on arrays rathern than ranges, but populate the arrays from your ranges)
    Dim aCalID() As Variant:    aCalID = rCal.Value
    Dim aCalData() As Variant:  aCalData = Intersect(rCal.EntireRow, wsCal.Columns("W:Y")).Value
    Dim aAnaData() As Variant:  aAnaData = rAna.Resize(, 4).Value
    
    'Declare and prep a Dictionary object variable
    'The dictionary will be used to perform lookup comparisons quickly to find matches
    Dim hAna As Object: Set hAna = CreateObject("Scripting.Dictionary")
    Dim aTemp() As Variant
    Dim sAnaID As String, sCalID As String
    Dim i As Long, j As Long
    
    'Loop through your AnaData to populate the dictionary
    For i = 1 To UBound(aAnaData, 1)
        sAnaID = LCase(aAnaData(i, 1))
        If Not hAna.Exists(sAnaID) Then
            ReDim aTemp(1 To UBound(aAnaData, 2) - 1)
            For j = 1 To UBound(aTemp)
                aTemp(j) = aAnaData(i, j   1)
            Next j
            hAna.Add sAnaID, aTemp
            Erase aTemp
        Else
            ReDim aTemp(1 To UBound(aAnaData, 2) - 1)
            For j = 1 To UBound(aTemp)
                aTemp(j) = aAnaData(i, j   1)
            Next j
            hAna(sAnaID) = aTemp
            Erase aTemp
        End If
    Next i
    
    'Dictionary has now been populated
    'Loop through your CalData and use the dictionary to perform fast lookups
    Dim bUpdate As Boolean: bUpdate = False
    For i = 1 To UBound(aCalID, 1)
        sCalID = LCase(aCalID(i, 1))
        If hAna.Exists(sCalID) Then
            'Matching IDs (values in column A of both sheets) found, update Cal Data columns
            bUpdate = True
            For j = 1 To UBound(aCalData, 2)
                aCalData(i, j) = hAna(sCalID)(j)
            Next j
        End If
    Next i
    
    'If any updates are necessary, output the results with the updated data
    If bUpdate Then wsCal.Range("W2").Resize(UBound(aCalData, 1), UBound(aCalData, 2)).Value = aCalData
    
'If any errors in the code were encountered, skip to here to ensure that app states get re-enabled
CleanExit:
    EnableAppStates
    MsgBox "The runtime of this program is " & Timer - dTimer & " seconds.", , "Runtime"
    
End Sub

Sub DisableAppStates()
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .DisplayStatusBar = False
        .Calculation = xlCalculationManual
    End With
    
End Sub

Sub EnableAppStates()
    
    With Application
        .Calculation = xlCalculationAutomatic
        .DisplayStatusBar = True
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
End Sub