Replace Index Match with VBA - Multiple Criteria - Thousands of rows and columns

Hi jaybrd1,

I agree that so many CSE formula cells in a workbook AND lots of Conditional Formatting cells will slow your work down. Have you considered showing all your information using Pivot Tables?? If you keep all your CSE formulas it will never speed up.

If you combine all your monthly sheets onto a single one, I believe Pivots could give you more information than you have now. I'm positive it would be much faster.

You can Group Dates and have filters by department or by type or category much easier with a Pivot.

Look at
http://chandoo.org/wp/2009/11/17/gro...-pivot-tables/ or
http://fiveminutelessons.com/learn-m...el-pivot-table

You didn't really give us enough data to show what Pivots can do..

Hi,
Here's a suggestion using VBA.

Note that I used your first file to make this macro and it will only compile JAN and FEV for demonstration purpose. I don't have time to continue it this morning but as you can see this can be pretty fast.

Hi,
Sorry, I was in a hurry this morning when I sent you the code.
I forgot to say that you need to click on the button to run the macro.
I used the names in rows 23 to 32 to test and compare the results with the names in rows 10-19. You can change the loop and delete those names I added.

Here's an updated version of the code, that will loop through all sheets. Change the values of shNames as required.

Sub Compile()
    Dim Dic, DicT
    Dim ar, shNames
    Dim i As Long, n As Long, j As Long, sName As String
    Dim rg As Range, c As Range
    Dim ws As Worksheet
    

    Application.ScreenUpdating = False
    
    shNames = "JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC"     '<<SHEET NAMES
    shNames = Split(shNames, ",")

    Set Dic = CreateObject("scripting.dictionary")
    
    'Loop through all sheets
    For n = LBound(shNames) To UBound(shNames)
    
       'Check if sheets exists
       On Error Resume Next
      Set ws = Sheets(shNames(n))
      On Error GoTo 0
      If Not ws Is Nothing Then
         ar = ws.Cells(1).CurrentRegion.Value
       'Populate dictionary
         For i = 1 To UBound(ar, 1)
             If ar(i, 1) <> "" Then
                 If Not Dic.exists(ar(i, 1)) Then
                     Set Dic(ar(i, 1)) = CreateObject("Scripting.dictionary")
                     Dic(ar(i, 1)).Add ar(i, 7), ar(i, 10)
                 Else
                     Dic(ar(i, 1)).Add ar(i, 7), ar(i, 10)
                 End If
             End If
         Next i
         Set ws = Nothing
      End If
    Next n

    'Write back in sheet
    With Sheets("EMER")
        For n = 23 To 32        '<<TEST ONLY, CHANGE THE LOOP 
            sName = .Cells(n, 2)
            If Dic.exists(sName) Then
                Set DicT = Dic(sName)
                Set rg = .Range("Q1:CA1")   '<<CHANGE THIS RANGE TO HAVE COMPLETE YEAR
                For Each c In rg
                    If DicT.exists(c.Value) Then .Cells(n, c.Column) = DicT(c.Value)
                Next c
            End If
        Next n
    End With

    Application.ScreenUpdating = True

End Sub

I tested it on a fresh copy with real data, and I first encountered:

Run-time error '457': This key is already associated with an element of this collection.
After looking up that error, I determined it was due to having multiple entries where the name and date were the same. I removed those as I really do not want duplicates.

I then got:
Run-time error '13': Type mismatch

I looked up this error but got lost

Debugging highlights this line:

'Populate dictionary
For i = 1 To UBound(ar, 1)

I get the error whether running in the VBA application or pressing the button I made to run the macro.

Here is the exact code I used with the adjustments:

Sub Compile()
    Dim Dic, DicT
    Dim ar, shNames
    Dim i As Long, n As Long, j As Long, sName As String
    Dim rg As Range, c As Range
    Dim ws As Worksheet
    

    Application.ScreenUpdating = False
    
    shNames = "JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC"     '<<SHEET NAMES
    shNames = Split(shNames, ",")

    Set Dic = CreateObject("scripting.dictionary")
    
    'Loop through all sheets
    For n = LBound(shNames) To UBound(shNames)
    
       'Check if sheets exists
       On Error Resume Next
      Set ws = Sheets(shNames(n))
      On Error GoTo 0
      If Not ws Is Nothing Then
         ar = ws.Cells(1).CurrentRegion.Value
       'Populate dictionary
         For i = 1 To UBound(ar, 1)
             If ar(i, 1) <> "" Then
                 If Not Dic.exists(ar(i, 1)) Then
                     Set Dic(ar(i, 1)) = CreateObject("Scripting.dictionary")
                     Dic(ar(i, 1)).Add ar(i, 7), ar(i, 10)
                 Else
                     Dic(ar(i, 1)).Add ar(i, 7), ar(i, 10)
                 End If
             End If
         Next i
         Set ws = Nothing
      End If
    Next n

    'Write back in sheet
    With Sheets("EMER")
        For n = 8 To 1500        '<<TEST ONLY, CHANGE THE LOOP
            sName = .Cells(n, 2)
            If Dic.exists(sName) Then
                Set DicT = Dic(sName)
                Set rg = .Range("Q1:NZ1")   '<<CHANGE THIS RANGE TO HAVE COMPLETE YEAR
                For Each c In rg
                    If DicT.exists(c.Value) Then .Cells(n, c.Column) = DicT(c.Value)
                Next c
            End If
        Next n
    End With

    Application.ScreenUpdating = True

End Sub

In VBE, go in Display and show the Local Variable Window
The run the code.
When it stops, do you have any values in the variable "ar" (you should have a + sign to expand it)

In your months sheets, does your list always start in cell A1??
I used ar = ws.cells(1).currentregion.value. So this assumes there is a value in A1.

Check that and let me know.

Ok, GC, I played with it more and actually found the right window. The ar has no plus sign beside it. the other variables can be expanded, but not ar.
Module1 has a plus
Dic has a plus
shNames has a plus
ws has a plus

Dict, ar, I,n,j,sName,rg and c do not have a plus.

As I said all data should start on A1, this could be changed. Currently I only placed data in the JAN tab until we get it working.

Edit:
I added a line to Feb as it seems that was where it was getting the error. Now I am back to the Runtime 457 error, that was due to a duplicate date, I changed it and MAR was the culprit tab.
I added a line to each month and now it works!

Does this mean I will need to make a fictitious person to start each month or it will not work? Normally those tabs would stay empty until the start of the month.

Edit:
I added a line to Feb as it seems that was where it was getting the error. Now I am back to the Runtime 457 error, that was due to a duplicate date, I changed it and MAR was the culprit tab.
I added a line to each month and now it works!

Does this mean I will need to make a fictitious person to start each month or it will not work? Normally those tabs would stay empty until the start of the month.

I just saw your last post, so what I just said probably does not make sense.
When the code stops, click debug then hover your mouse on the line highlighted in yellow.

It should break at :

                Dic(ar(i, 1)).Add ar(i, 7), ar(i, 10)

if you place the cursor over ar(i, 1), ar(i, 7) and ar9(i, 10), what values do you see?

Hi,
If your data starts in A1 and it is a header (same for each sheet) then replace

         For i = 1 To UBound(ar, 1)

with

         For i = 2 To UBound(ar, 1)

As you found out, you can not have duplicate keys in a dictionary. So you need to exclude the header from the compilation by starting in row 2.

I'd need to see your file.

You could change the shNames variable to skip the past months and
you can also change the rg variable to skip the past dates.