Excel VBA Code performance is Extremely Slow

Admin 1
Viewed 412

I have wrote a code which is working like Turtle walks. I have added Application Functions to make it faster but code has decided that he has to work slowly.

Any expert help will be appreciated.

Dim LastRowColumnA As Long
Dim i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
LastRowColumnA = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 11 To LastRowColumnA
If Sheet1.Cells(i, 1).Value <> "" Then
Cells(i, 7) = Evaluate("=INDEX(Table1!$A$1:$DP$27,MATCH($G$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A" & i & ",Table1!$6:$6,0))")
Cells(i, 8) = Evaluate("=INDEX(Table1!$A$1:$DP$27,MATCH($H$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A" & i & ",Table1!$6:$6,0))")
Cells(i, 9) = Evaluate("=INDEX(Table1!$A$1:$DP$27,MATCH($I$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A" & i & ",Table1!$6:$6,0))")
Cells(i, 10) = Evaluate("=INDEX(Table1!$A$1:$DP$27,MATCH($J$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A" & i & ",Table1!$6:$6,0))")
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End If
Next

second approach.

Dim LastRowColumnA As Long
LastRowColumnA = Sheet1.Cells(Rows.Count, 4).End(xlUp).Row

Sheet1.Range("G10").FormulaArray = _
"=IFERROR(INDEX(Table1!R1C1:R27C120,MATCH(R9C7&R4C5,Table1!C5&Table1!C6,0),MATCH(RC[-6],Table1!R6,0)), """")"
Sheet1.Range("G10").AutoFill Destination:=Sheet1.Range("G10:G" & LastRowColumnA), Type:=xlFillDefault

Sheet1.Range("H10").FormulaArray = _
"=IFERROR(INDEX(Table1!R1C1:R27C120,MATCH(R9C8&R4C5,Table1!C5&Table1!C6,0),MATCH(RC[-7],Table1!R6,0)), """")"
Sheet1.Range("H10").AutoFill Destination:=Sheet1.Range("H10:H" & LastRowColumnA), Type:=xlFillDefault

Sheet1.Range("I10").FormulaArray = _
"=IFERROR(INDEX(Table1!R1C1:R27C120,MATCH(R9C9&R4C5,Table1!C5&Table1!C6,0),MATCH(RC[-8],Table1!R6,0)), """")"
Sheet1.Range("I10").AutoFill Destination:=Sheet1.Range("I10:I" & LastRowColumnA), Type:=xlFillDefault

Sheet1.Range("J10").FormulaArray = _
"=IFERROR(INDEX(Table1!R1C1:R27C120,MATCH(R9C9&R4C5,Table1!C5&Table1!C6,0),MATCH(RC[-9],Table1!R6,0)), """")"
Sheet1.Range("J10").AutoFill Destination:=Sheet1.Range("J10:J" & LastRowColumnA), Type:=xlFillDefault

Formulas of First Cells which has been converted to code.

=IFERROR(INDEX(Table1!$A$1:$DP$27,MATCH($G$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A10,Table1!$6:$6,0)), "")

=IFERROR(INDEX(Table1!$A$1:$DP$27,MATCH($H$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A10,Table1!$6:$6,0)), "")

=IFERROR(INDEX(Table1!$A$1:$DP$27,MATCH($I$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A10,Table1!$6:$6,0)), "")

=IFERROR(INDEX(Table1!$A$1:$DP$27,MATCH($J$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A10,Table1!$6:$6,0)), "")
vba excel
1 Answers

as per my comment:

Find the rows outside the loop as they will all be the same, then just find the column in the loop. It will cut down on the number of calc.

Dim LastRowColumnA As Long
Dim i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheet1
    LastRowColumnA = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    
    Dim gRow As Variant
    gRow = .Evaluate("MATCH($G$9&$E$4,Table1!$E1:$E27&Table1!$F1:$F27,0)")
    
    Dim hRow As Variant
    hRow = .Evaluate("MATCH($H$9&$E$4,Table1!$E1:$E27&Table1!$F1:$F27,0)")
    
    Dim iRow As Variant
    iRow = .Evaluate("MATCH($I$9&$E$4,Table1!$E1:$E27&Table1!$F1:$F27,0)")
    
    Dim jRow As Variant
    jRow = .Evaluate("MATCH($J$9&$E$4,Table1!$E1:$E27&Table1!$F1:$F27,0)")
    
    For i = 11 To LastRowColumnA
        If Sheet1.Cells(i, 1).Value <> "" And Not IsError(gRow) And Not IsError(hRow) And Not IsError(iRow) And Not IsError(jRow) Then
            Dim clm As Variant
            clm = Application.Match(.Range("A" & i), Worksheets("Table1").Range("6:6"), 0)
            If Not IsError(clm) Then
                .Cells(i, 7) = Worksheets("Table1").Cells(gRow, clm)
                .Cells(i, 8) = Worksheets("Table1").Cells(hRow, clm)
                .Cells(i, 9) = Worksheets("Table1").Cells(iRow, clm)
                .Cells(i, 10) = Worksheets("Table1").Cells(jRow, clm)
            End If
        End If
    Next
End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

If that is still too slow then one will need to use variant arrays and skip looping the ranges as this is slow.

user_48515900
Related