Index match VBA taking too long

youbitto

youbitto

New Member
Joined
Jun 8, 2022
Messages
34
Office Version
  1. 2019
  2. 2016
  3. 2013
Platform
  1. Windows
Hello!

I have this code to index match multiple columns from 2 different sheets at ones but the it takes too long to complete, the code has a column change to text format and another one to run mid()

so my requests are :

1. make the code run faster

2. make a percentage of completion
VBA Code: 
Sub INDEX_MATCH()

Dim k As Long

Dim i As Long

i = ActiveSheet.UsedRange.Rows.Count



' k is the column number

For k = 5 To i



Sheets("listCreance").Cells(k, 17).Value = WorksheetFunction.Index(Sheets("List Clients").Range("H:H"), WorksheetFunction.Match(Sheets("listCreance").Cells(k, 4).Value, Sheets("List Clients").Range("F:F"), 0)) 'Adresse
Sheets("listCreance").Cells(k, 18).Value = WorksheetFunction.Index(Sheets("List Clients").Range("U:U"), WorksheetFunction.Match(Sheets("listCreance").Cells(k, 4).Value, Sheets("List Clients").Range("F:F"), 0)) 'N Cpt
Sheets("listCreance").Cells(k, 19).Value = WorksheetFunction.Index(Sheets("List Clients").Range("D:D"), WorksheetFunction.Match(Sheets("listCreance").Cells(k, 4).Value, Sheets("List Clients").Range("F:F"), 0)) 'Nom Client
Sheets("listCreance").Cells(k, 20).Value = WorksheetFunction.Index(Sheets("List Clients").Range("F:F"), WorksheetFunction.Match(Sheets("listCreance").Cells(k, 4).Value, Sheets("List Clients").Range("F:F"), 0)) 'Reference
Sheets("listCreance").Cells(k, 21).Value = WorksheetFunction.Index(Sheets("List Clients").Range("M:M"), WorksheetFunction.Match(Sheets("listCreance").Cells(k, 4).Value, Sheets("List Clients").Range("F:F"), 0)) 'Tarif
Sheets("listCreance").Cells(k, 22).Value = WorksheetFunction.Index(Sheets("List Clients").Range("R:R"), WorksheetFunction.Match(Sheets("listCreance").Cells(k, 4).Value, Sheets("List Clients").Range("F:F"), 0)) 'Etat
Sheets("listCreance").Cells(k, 25).Value = WorksheetFunction.Index(Sheets("List Clients").Range("S:S"), WorksheetFunction.Match(Sheets("listCreance").Cells(k, 4).Value, Sheets("List Clients").Range("F:F"), 0)) 'Date Résiliation

Sheets("listCreance").Cells(k, 23).Value = Mid(Sheets("listCreance").Cells(k, 21), 3, 2)
Sheets("listCreance").Cells(k, 24).Value = Mid(Sheets("listCreance").Cells(k, 20), 1, 7)

On Error Resume Next

Next k

Sheets("listCreance").Columns("T:T").NumberFormat = "000000000000000"

End Sub
 
Sort by date Sort by votes
My guess it that you have an #N/A of some other error in Column F and/or Column D respectively.

The below will skip over those lines

Rich (BB code): 
Sub DictionaryLookup()

    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim rngSrc As Range, rngDestIdx As Range, rngDestOut As Range
    Dim arrSrc As Variant, arrDestIdx As Variant, arrDestOut As Variant
    Dim rowLastSrc As Long, rowLastDest As Long
    Dim i As Long, j As Long, colOffset As Long
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set shtSrc = Worksheets("List Clients")
    With shtSrc
        rowLastSrc = .Range("F" & Rows.Count).End(xlUp).Row             ' Use Lookup column
        Set rngSrc = .Range("A1:U" & rowLastSrc)
        arrSrc = rngSrc.Value2
    End With
   
    Set shtDest = Worksheets("listCreance")
    With shtDest
        rowLastDest = .Range("D" & Rows.Count).End(xlUp).Row            ' Use Lookup Value column
        Set rngDestIdx = .Range("D5:D" & rowLastDest)
        arrDestIdx = rngDestIdx.Value2
        Set rngDestOut = .Range("Q" & rngDestIdx.Row)
        ReDim arrDestOut(1 To UBound(arrDestIdx), 1 To 9)               ' Columns 17 (Q) to 25
    End With
   
    ' Column mapping
    Dim colSrc As Variant, colDest As Variant
    colSrc = Array(8, 21, 4, 6, 13, 18, 19)
    colDest = Array(17, 18, 19, 20, 21, 22, 25)
    colOffset = rngDestOut.Column - 1                                   ' Output range starts at Q (col 17) = array col 1
   
    Dim dictSrc As Object, dictKey As String

    Set dictSrc = CreateObject("Scripting.dictionary")
    dictSrc.CompareMode = vbTextCompare
   
    ' Load details range into Dictionary
    For i = 1 To UBound(arrSrc)
       
        If Not IsError(arrSrc(i, 6)) Then
            dictKey = arrSrc(i, 6)                                          ' 6 is column F
            If Not dictSrc.exists(dictKey) Then
                dictSrc(dictKey) = i
            End If
        End If
    Next i

    ' Get values using Dictionary
   
   
    For i = 1 To UBound(arrDestIdx)
        If Not IsError(arrSrc(i, 1)) Then
            dictKey = arrDestIdx(i, 1)                                          ' Column D lookup value
            If dictSrc.exists(dictKey) Then
                For j = 0 To UBound(colSrc)
                    arrDestOut(i, colDest(j) - colOffset) = arrSrc(dictSrc(dictKey), colSrc(j))
                Next j
                arrDestOut(i, 23 - colOffset) = Mid(arrDestOut(i, 5), 3, 2)     ' U -> W
                arrDestOut(i, 24 - colOffset) = Mid(arrDestOut(i, 4), 1, 7)     ' T -> X
            End If
        End If
    Next i
   
    ' Write back Rpt updated data
    rngDestOut.Resize(UBound(arrDestOut), UBound(arrDestOut, 2)).Value2 = arrDestOut
    shtDest.Columns("T:T").NumberFormat = String(15, "0")
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

   
End Sub
 
Upvote 0

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Hello @
Alex Blakenburg said:
It doesn't sound like you are familiar with the immediate window.

When you are in the VBA screen enter Ctrl+G a window will pop up called the immediate window.
When the code crashes enter
? i and hit enter (enter question mark followed by i )
Then enter
? arrSrc(i,6) and hit enter
Then go to that line in the Client List
Click to expand...
Retried the code and it worked hhhhhhh dont know how

also what I am trying to do to the column T is that I need instead of "18080202939142" it shows "018080202939142" and stays like that as a text, I tweak the code before yours and did "Format(.Cells(k, 4), "000000000000000")"
with your code it a high end one for me
 
Upvote 0
Alex Blakenburg said:
My guess it that you have an #N/A of some other error in Column F and/or Column D respectively.

The below will skip over those lines

Rich (BB code): 
Sub DictionaryLookup()

    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim rngSrc As Range, rngDestIdx As Range, rngDestOut As Range
    Dim arrSrc As Variant, arrDestIdx As Variant, arrDestOut As Variant
    Dim rowLastSrc As Long, rowLastDest As Long
    Dim i As Long, j As Long, colOffset As Long
  
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
  
    Set shtSrc = Worksheets("List Clients")
    With shtSrc
        rowLastSrc = .Range("F" & Rows.Count).End(xlUp).Row             ' Use Lookup column
        Set rngSrc = .Range("A1:U" & rowLastSrc)
        arrSrc = rngSrc.Value2
    End With
  
    Set shtDest = Worksheets("listCreance")
    With shtDest
        rowLastDest = .Range("D" & Rows.Count).End(xlUp).Row            ' Use Lookup Value column
        Set rngDestIdx = .Range("D5:D" & rowLastDest)
        arrDestIdx = rngDestIdx.Value2
        Set rngDestOut = .Range("Q" & rngDestIdx.Row)
        ReDim arrDestOut(1 To UBound(arrDestIdx), 1 To 9)               ' Columns 17 (Q) to 25
    End With
  
    ' Column mapping
    Dim colSrc As Variant, colDest As Variant
    colSrc = Array(8, 21, 4, 6, 13, 18, 19)
    colDest = Array(17, 18, 19, 20, 21, 22, 25)
    colOffset = rngDestOut.Column - 1                                   ' Output range starts at Q (col 17) = array col 1
  
    Dim dictSrc As Object, dictKey As String

    Set dictSrc = CreateObject("Scripting.dictionary")
    dictSrc.CompareMode = vbTextCompare
  
    ' Load details range into Dictionary
    For i = 1 To UBound(arrSrc)
      
        If Not IsError(arrSrc(i, 6)) Then
            dictKey = arrSrc(i, 6)                                          ' 6 is column F
            If Not dictSrc.exists(dictKey) Then
                dictSrc(dictKey) = i
            End If
        End If
    Next i

    ' Get values using Dictionary
  
  
    For i = 1 To UBound(arrDestIdx)
        If Not IsError(arrSrc(i, 1)) Then
            dictKey = arrDestIdx(i, 1)                                          ' Column D lookup value
            If dictSrc.exists(dictKey) Then
                For j = 0 To UBound(colSrc)
                    arrDestOut(i, colDest(j) - colOffset) = arrSrc(dictSrc(dictKey), colSrc(j))
                Next j
                arrDestOut(i, 23 - colOffset) = Mid(arrDestOut(i, 5), 3, 2)     ' U -> W
                arrDestOut(i, 24 - colOffset) = Mid(arrDestOut(i, 4), 1, 7)     ' T -> X
            End If
        End If
    Next i
  
    ' Write back Rpt updated data
    rngDestOut.Resize(UBound(arrDestOut), UBound(arrDestOut, 2)).Value2 = arrDestOut
    shtDest.Columns("T:T").NumberFormat = String(15, "0")
  
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

  
End Sub
Click to expand...
tried your new one and gives me this error
also 36421 is the last line in the list Client sheet
 

Attachments

  • image_2024-09-07_093732515.png
    image_2024-09-07_093732515.png
    44.6 KB · Views: 4
Upvote 0
Alex Blakenburg said:
Oops can you change that to
If Not IsError(arrDestIdx(i, 1)) Then
Click to expand...
Nice it worked and very fast, Mr Alex also what I am trying to do to the column T is that I need instead of "18080202939142" is that to show me "018080202939142" and stays like that as a text, I tweak the code before yours and did "Format(.Cells(k, 4), "000000000000000")"

shtDest.Columns("T:T").NumberFormat = String(15, "0") this one didn't give me what I wanted
 
Upvote 0
Replace from " ' Get values using Dictionary " to the end with this.
You will to check whether that means you need to change arrDestOut(i, 24 - colOffset) = Mid(arrDestOut(i, 4), 1, 7) ' T -> X
since it will have a leading zero added now.

Rich (BB code): 
    ' Get values using Dictionary
    For i = 1 To UBound(arrDestIdx)
        If Not IsError(arrDestIdx(i, 1)) Then
            dictKey = arrDestIdx(i, 1)                                          ' Column D lookup value
            If dictSrc.exists(dictKey) Then
                For j = 0 To UBound(colSrc)
                    arrDestOut(i, colDest(j) - colOffset) = arrSrc(dictSrc(dictKey), colSrc(j))
                Next j
                arrDestOut(i, 23 - colOffset) = Mid(arrDestOut(i, 5), 3, 2)     ' U -> W
                arrDestOut(i, 4) = Format(arrDestOut(i, 4), String(15, "0"))
                arrDestOut(i, 24 - colOffset) = Mid(arrDestOut(i, 4), 1, 7)     ' T -> X
            End If
        End If
    Next i
   
    ' Write back Rpt updated data
    shtDest.Columns("T:T").NumberFormat = "@"             
    rngDestOut.Resize(UBound(arrDestOut), UBound(arrDestOut, 2)).Value2 = arrDestOut

   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
Solution
Alex Blakenburg said:
Replace from " ' Get values using Dictionary " to the end with this.
You will to check whether that means you need to change arrDestOut(i, 24 - colOffset) = Mid(arrDestOut(i, 4), 1, 7) ' T -> X
since it will have a leading zero added now.

Rich (BB code): 
    ' Get values using Dictionary
    For i = 1 To UBound(arrDestIdx)
        If Not IsError(arrSrc(i, 1)) Then
            dictKey = arrDestIdx(i, 1)                                          ' Column D lookup value
            If dictSrc.exists(dictKey) Then
                For j = 0 To UBound(colSrc)
                    arrDestOut(i, colDest(j) - colOffset) = arrSrc(dictSrc(dictKey), colSrc(j))
                Next j
                arrDestOut(i, 23 - colOffset) = Mid(arrDestOut(i, 5), 3, 2)     ' U -> W
                arrDestOut(i, 4) = Format(arrDestOut(i, 4), String(15, "0"))
                arrDestOut(i, 24 - colOffset) = Mid(arrDestOut(i, 4), 1, 7)     ' T -> X
            End If
        End If
    Next i
   
    ' Write back Rpt updated data
    shtDest.Columns("T:T").NumberFormat = "@"             
    rngDestOut.Resize(UBound(arrDestOut), UBound(arrDestOut, 2)).Value2 = arrDestOut

   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
Click to expand...
Thank you Very much Mr. Alex
Also changed "If Not IsError(arrDestIdx(i, 1)) Then"
and it works like a charm
I hope someday to get to your level in VBA coding
 
Upvote 0
You must log in or register to reply here.

Similar threads

montecarlo2012
  • Question Question
change display from horizontal to vertical
Replies
2
Views
98
montecarlo2012
montecarlo2012
E
  • Solved
VBA Index Match (Error Handling)
Replies
5
Views
536
kevin9999
K
WERNER SLABBERT
  • Question Question
Run-time error 70 after code changed
Replies
3
Views
65
RoryA
RoryA
HansM
  • Question Question
Looking for a specific number in a cell that can have multiple numbers separated by a comma (Using Mac Excel)
Replies
5
Views
294
Jeffrey Mahoney
Jeffrey Mahoney
M
  • Solved
Optimizing my rows to send e-mail to different address
Replies
2
Views
169
MasterBash
M

Forum statistics

Threads
1,223,877
Messages
6,175,137
Members
452,614
Latest member
MRSWIN2709

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top