Index Match VBA is very slow, and question to index match loop through column as well

[hwong8848]

Hi all, I have made a little VBA to lookup value from another sheet but it is very slow already loop thru row. How can I speed it up and also make it loop through row?

Sub filldata()
'find rollupcode from data abailability tab

    'Speed up VBA, turning off other components
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    'Set Variable
    Dim wb1 As Workbook, wb2 As Workbook, ws1 As Worksheet, ws2 As Worksheet
    
    'Market Data File
    Set wb1 = Workbooks("checking_v0.2.xlsx")
    Set ws1 = wb1.Worksheets("data availability check")
    Set ws3 = wb1.Worksheets("peer group market data")
    
    'Template
    Set wb2 = Workbooks("Benchmarking.xlsm")
    Set ws2 = wb2.Worksheets("MarketData")
    


    'For Vlookup Roll up Grade
    ws1.Activate
    Set fulljobcode = ws1.Range("J2", Range("J" & Rows.Count).End(xlUp))
    Set rollupcode = ws1.Range("K2", Range("K" & Rows.Count).End(xlUp))
    Set vlookuparray = ws1.Range("J:K")
    
    With ws2
    
    wb2.Activate
    lastRow = Range("B" & Rows.Count).End(xlUp).row

        For r = 3 To lastRow
        Cells(r, 2) = Application.VLookup(Cells(r, 1), vlookuparray, 2, False)
        Next r

    End With
    
    'For Index Match Market Data
    Set col_array = ws3.Range("A1:PN1")
    Set row_array = ws3.Range("A2:A14365")
    index_array = ws3.Range("A1:PN14365")
    lastRow = ws2.Range("B" & Rows.Count).End(xlUp).row
    'lastCol = ws2.Range("C2").End(xlToRight).col
    
    With ws2
    
        For i = 3 To lastRow
        On Error Resume Next
        Cells(i, 3) = Application.Index(index_array, _
        Application.Match(Cells(i, 2), row_array, 0), Application.Match(Cells(1, 3), col_array, 0))
        
        Next i

    'Turn things back on
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    End With
    
End Sub

 

[DanteAmor]

Hi and welcome to MrExcel!

I think this value in row_array should also be A1, to match the index_array.

    Set col_array = ws3.Range("A1:PN1")
    Set row_array = ws3.Range("A2:A14365")
    index_array = ws3.Range("A1:PN14365")

Try the following code with 16,000 records and columns from A to PN, the process is 1.5 seconds.

Sub filldata()
'find rollupcode from data abailability tab

  'Set Variable
  Dim wb1 As Workbook, wb2 As Workbook
  Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
  Dim dic As Object
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, col As Long
  Dim f As Range
  
  'Market Data File
  Set wb1 = Workbooks("checking_v0.2.xlsx")
  Set ws1 = wb1.Worksheets("data availability check")
  Set ws3 = wb1.Worksheets("peer group market data")
  
  'Template
  Set wb2 = Workbooks("Benchmarking.xlsm")
  Set ws2 = wb2.Worksheets("MarketData")
  
  'Create dictionary
  Set dic = CreateObject("Scripting.Dictionary")
  dic.comparemode = vbTextCompare
  
  a = ws1.Range("J2:K" & ws1.Range("J" & Rows.Count).End(xlUp).Row).Value
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 1)) Then
      dic(a(i, 1)) = a(i, 2)
    End If
  Next

  'For Vlookup Roll up Grade
  b = ws2.Range("A3", ws2.Range("A" & Rows.Count).End(xlUp)).Value
  ReDim c(1 To UBound(b, 1), 1 To 1)
  For i = 1 To UBound(b, 1)
    If dic.exists(b(i, 1)) Then
      c(i, 1) = dic(b(i, 1))
    End If
  Next
  ws2.Range("B3").Resize(UBound(c, 1)).Value = c
    
  Erase a, b, c
  dic.RemoveAll
  
  'For Index Match Market Data
  a = ws3.Range("A1:PN" & ws3.Range("A" & Rows.Count).End(3).Row).Value
  Set f = ws3.Range("A1:PN1").Find(ws2.Range("C1").Value, , xlValues, xlWhole, , , False)
  If Not f Is Nothing Then
    col = f.Column
    For i = 1 To UBound(a, 1)
      If Not dic.exists(a(i, 1)) Then
        dic(a(i, 1)) = a(i, col)
      End If
    Next
    b = ws2.Range("B3:B" & ws2.Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim c(1 To UBound(b, 1), 1 To 1)
    For i = 1 To UBound(b, 1)
      If dic.exists(b(i, 1)) Then
        c(i, 1) = dic(b(i, 1))
      End If
    Next
    ws2.Range("C3").Resize(UBound(c, 1)).Value = c
  End If

End Sub

If the index is correct as you have it in your code, then try the following:

Sub filldata()
'find rollupcode from data abailability tab

  'Set Variable
  Dim wb1 As Workbook, wb2 As Workbook
  Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
  Dim dic As Object
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, col As Long
  Dim f As Range
  
  'Market Data File
  Set wb1 = Workbooks("checking_v0.2.xlsx")
  Set ws1 = wb1.Worksheets("data availability check")
  Set ws3 = wb1.Worksheets("peer group market data")
  
  'Template
  Set wb2 = Workbooks("Benchmarking.xlsm")
  Set ws2 = wb2.Worksheets("MarketData")
  
  'Create dictionary
  Set dic = CreateObject("Scripting.Dictionary")
  dic.comparemode = vbTextCompare
  
  a = ws1.Range("J2:K" & ws1.Range("J" & Rows.Count).End(xlUp).Row).Value
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 1)) Then
      dic(a(i, 1)) = a(i, 2)
    End If
  Next

  'For Vlookup Roll up Grade
  b = ws2.Range("A3", ws2.Range("A" & Rows.Count).End(xlUp)).Value
  ReDim c(1 To UBound(b, 1), 1 To 1)
  For i = 1 To UBound(b, 1)
    If dic.exists(b(i, 1)) Then
      c(i, 1) = dic(b(i, 1))
    End If
  Next
  ws2.Range("B3").Resize(UBound(c, 1)).Value = c
    
  Erase a, b, c
  dic.RemoveAll
  
  'For Index Match Market Data
  a = ws3.Range("A2:PN" & ws3.Range("A" & Rows.Count).End(3).Row).Value
  Set f = ws3.Range("A2:PN1").Find(ws2.Range("C1").Value, , xlValues, xlWhole, , , False)
  If Not f Is Nothing Then
    col = f.Column
    For i = 2 To UBound(a, 1)
      If Not dic.exists(a(i, 1)) Then
        dic(a(i, 1)) = a(i - 1, col)
      End If
    Next
    b = ws2.Range("B3:B" & ws2.Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim c(1 To UBound(b, 1), 1 To 1)
    For i = 1 To UBound(b, 1)
      If dic.exists(b(i, 1)) Then
        c(i, 1) = dic(b(i, 1))
      End If
    Next
    ws2.Range("C3").Resize(UBound(c, 1)).Value = c
  End If

End Sub