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)), "")
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.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.