Index Match Multiple Criteria VBA

[Jimmy1772]

I'm trying to index match multiple criteria using VBA. I'm trying to do this to avoid using loops to speed this up on large files. I've attached a small example. Any ideas? Thank you!

Option Explicit

Sub match()
Dim wb As Workbook
Set wb = Application.ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Sheet1")
Dim NewTable As Object
Set NewTable = ws.ListObjects("Table1")


Dim food As Range
Set food = NewTable.ListColumns("food").DataBodyRange

Dim product As Range
Set product = NewTable.ListColumns("product").DataBodyRange

Dim period As Range
Set period = NewTable.ListColumns("period").DataBodyRange

Dim target_period As Long
target_period = 4
Dim target_product As String
target_product = "b"

Dim yay As String

yay = Application.WorksheetFunction.Index(food, _
Application.WorksheetFunction.match(target_period & "&" & target_product, _
Application.WorksheetFunction.Index(period & product, 0), 0))

yay = Application.WorksheetFunction.Index(food, _
Application.WorksheetFunction.Index( _
Application.WorksheetFunction.match(1, (period = target_period) * (product = target_product), 0), 1))

yay = Application.WorksheetFunction.Index(NewTable, _
Application.WorksheetFunction.match(1, (period = target_period) * (product = target_product), 0))

End Sub

 

[kennypete]

It's not 100% clear to me what the end goal is, however, if it is to determine quickly the answer to Period-Product then a dictionary seems the best way to go?

Sub ReturnFood()
    Dim j As Long, dic As Object, ui
    Set dic = CreateObject("Scripting.Dictionary")
    For j = 2 To Sheet1.ListObjects("Table1").DataBodyRange.Rows.Count
        dic(Cells(j, 1).Value & Cells(j, 2).Value) = Cells(j, 3).Value
    Next
    ui = InputBox("Period and Product?")
    MsgBox ("Period " & Left(ui, 1) & " Product " & Right(ui, 1) & " is " & dic(ui))
End Sub

Run on:

Book1
	A	B	C
1	period	product	food
2	1	a	potato
3	2	a	tomato
4	3	a	cauliflower
5	4	a	bananas
6	1	b	potato
7	2	b	tomato
8	3	b	cauliflower
9	4	b	bananas
10	1	c	potato
11	2	c	tomato
12	3	c	cauliflower
13	4	c	bananas
14	1	d	potato
15	2	d	tomato
16	3	d	cauliflower
17	4	d	bananas
Sheet1

>

 

[Peter_SSs]

Welcome to the MrExcel board!

avoid using loops to speed this up on large files.

1. How large is your file (approximate number of rows in the table)?

2. Don't be put off looping as such, but looping and interacting with the worksheet each loop can be relatively slow.

3. I would also suggest putting all your variable declarations at the start of the code - makes them easier to find if you need to check what the declaration is at a later time.

Anyway, you might also like to try this code. You will see that kennypete's code and mine both use loops yet both I think you will find reasonably fast.
However, with, say, 100,000 rows, my testing was that this code is about 30 times faster than that in post 2 when the item found is near the bottom of that data. If the item found is near the top of the data, it was more like 40 times faster, as my code stops looping as soon as the required item is encountered.

The major reason that this code is faster is that all the data is read into memory at the beginning and all the searching is done there - no interactions with the worksheet during the looping.

Sub Return_Food()
  Dim wb As Workbook
  Dim ws As Worksheet
  Dim NewTable As Object
  Dim a As Variant
  Dim target_period As Long
  Dim target_product As String
  Dim period_col As Long
  Dim product_col As Long
  Dim food_col As Long
  Dim i As Long
  Dim bFound As Boolean
  
  Set wb = Application.ThisWorkbook
  Set ws = wb.Sheets("Sheet1")
  Set NewTable = ws.ListObjects("Table1")
  target_period = 4
  target_product = "b"
  period_col = NewTable.ListColumns("period").Index
  product_col = NewTable.ListColumns("product").Index
  food_col = NewTable.ListColumns("food").Index
  a = NewTable.DataBodyRange.Value
  For i = 1 To UBound(a)
    If a(i, period_col) = target_period Then
      If a(i, product_col) = target_product Then
        bFound = True
      End If
    End If
    If bFound Then Exit For
  Next i
  If bFound Then
    MsgBox "Period: " & target_period & vbLf & "Product: " & target_product & vbLf & "Food: " & a(i, food_col)
  Else
    MsgBox "Period: " & target_period & vbLf & "Product: " & target_product & vbLf & "Food: Not found"
  End If
  
End Sub

 

[kennypete]

Yes, as @Peter_SSs says, his post #3 will be much faster than my post #2 with tens of thousands of rows (noting too I had omitted to check for whether the key already existed, presuming the Period-Product combinations are unique).

A third option, if speed is a concern, would be to use a SQL query. There's no looping here at all in this approach (though, I agree, that shouldn't be a show-stopper). I tested this on 100,000 rows with 4-b at the end and the difference in speed was immaterial, so I'd say you have a surplus of choice

Sub ReturnFoodv3()
    Dim cn As Object, rs As Object, sql As String
    Set cn = CreateObject("ADODB.Connection")
    With cn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & ThisWorkbook.Path & "\" & _
            ThisWorkbook.Name & ";" & "Extended Properties=""Excel 12.0 Macro;HDR=YES"";"
        .Open
    End With
    sql = "SELECT * FROM [Sheet1$] WHERE period=4 and product='b'"
    Set rs = cn.Execute(sql)
    MsgBox "Period " & rs(0) & " + Product " & rs(1) & " = " & rs(2) & vbNewLine
    rs.Close
    cn.Close
    Set cn = Nothing
    Set rs = Nothing
End Sub

[Incidental: Normally you'd loop through the recordset, but you have unique Period-Product combinations? ... so there should only be one record returned making that loop unnecessary. I have also omitted any check for whether there was nothing found. And this version is hardcoded to 4-b, like Peter's.]

 

[Jimmy1772]

Thank you for all of the responses!

• How can I setup 4 and b as variables that are passed to the sql query?
• Can I have it return the table row as a variable?

I do have unique period-product combinations. I have two slave files on the computer "File A" and "File B". "File A" only contains a list of the period-product. "File B" contains a list of the period-product-food. Each "period-product" has its own excel file and a table within contains all of the foods associated. Each period-product may have up to 12 foods associated.

The user clicks the hyperlink for the "period-product" within either "File A" or "period-food" within "File B" which opens the individual project file where they are able to update a few areas of information and upon saving that information is passed back to update both "File A" and "File B" by determining which row that information is on then passing that information to those rows.

The issue I have with speed is particularly where a new line item is added. There's a template file that all of the other files are based off. If I pick a product it will assign the next highest period and all associated foods. I do the work in a hidden excel version so that the whole thing doesn't flicker - but then it takes around 16 seconds to loop through around 6600 lines in "File B". That's 16 seconds times the number of foods associated I have to wait.

'Check if the parent file is open
Ret = IsWorkBookOpen(FileBLocation)

If Ret = True Then
    'File is open, specify a variable to keep the workbook open when finished updating
    TrackingCheck = "0"
Else
    'File is closed
    Dim XlApp As New Excel.Application
    Set XlApp = New Excel.Application
    DoEvents
    XlApp.Visible = False
    XlApp.Workbooks.Open (parentdirectory & "\FileB.xlsm")
    DoEvents
    'specify a variable to close the workbook when finished updating
    TrackingCheck = "1"
End If

'Define the parent file
Set wbParent = GetObject(parentdirectory & "FileB.xlsm")
Set wsDest = wbParent.Worksheets("Sheet1")
Set DestTable = wsDest.ListObjects("Table1")

With the hidden version I find the screen doesn't flicker but it takes several minutes to actually loop through everything. I was hoping if I get rid of the loops I can get an acceptable run time.

 

[Jimmy1772]

Edit to add: How do I check for a lack of values as well?

 

[kennypete]

The code below will 1) seek the Period and Product combo from the user and 2) also check for no result/"lack of values".

What's not totally clear to me is what's going on with all your loops, opening files, etc. With the query version below the file(s) would not be opened as such; it would be read via the connection "Data Source=" & ThisWorkbook.Path & "\" ThisWorkbook.Name where you'd change that to whatever Workbooks (and specific Worksheets) are being queried.

So 2/3 ain't bad...without some samples (using XL2BB preferably, not screenshots) I'm not sure how to go about considering your 3rd aspect of all the files and time, but perhaps the code below does enough for you to figure that part anyway.

Finally, in terms of returning the "table row as a variable", you're basically getting that with rs(0) to rs(2) - you could just assign them to variables, an array or whatever.

Sub ReturnFoodv4()
    Dim cn As Object, rs As Object, sql As String
    Dim ui As String, lngPeriod As Long, strProduct As String
    ui = InputBox("Period and Product? (e.g. 1a)")
    lngPeriod = Int(Left(Trim(ui), 1))
    strProduct = Right(Trim(ui), Len(Trim(ui)) - 1)
    Set cn = CreateObject("ADODB.Connection")
    With cn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & ThisWorkbook.Path & "\" & _
            ThisWorkbook.Name & ";" & "Extended Properties=""Excel 12.0 Macro;HDR=YES"";"
        .Open
    End With
    sql = "SELECT * FROM [Sheet1$] WHERE period=" & lngPeriod & " and " & _
                                        "product='" & strProduct & "'"
    Set rs = cn.Execute(sql)
    If rs.EOF Then
        MsgBox "Period " & lngPeriod & " + Product " & strProduct & " has no matching records." & vbNewLine
    Else
        MsgBox "Period " & rs(0) & " + Product " & rs(1) & " = " & rs(2) & vbNewLine
    End If
    rs.Close
    cn.Close
    Set cn = Nothing
    Set rs = Nothing
End Sub

 

[Jimmy1772]

So I'm kind of confused about the files not being opened part.

With the query version below the file(s) would not be opened as such

There's a workbook I want to put values into its tables while I operate from another workbook. If it wasn't already opened to keep the screen from flickering it's opened like this:

Dim XlApp As Excel.Application
Set XlApp = New Excel.Application
DoEvents
XlApp.Visible = False
XlApp.Workbooks.Open (WhereBookIWantToQueryIs & "\BookIWantToQuery.xlsm")

Then after I've done a little bit with it I want to also pull a query on it, but it's opened already as above since I'm not done yet. That's where I have a problem.

With cn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .Connectionstring = "Data Source= " & WhereBookIWantToQueryIs & "\BookIwantToQuery.xlsm" & ";" & "Extended Properties=""Excel 12.0 Macro;HDR=YES"";"
    .Open
End With

at

 .Open

I'll get an error telling me

BookIWantToQuery.xlsm is locked for editing
by 'My Name'.
Open 'Read-Only' or click 'Notify' to open read-only and receive notification when the document is no longer in use.

 

[kennypete]

Try it without the file opened in Excel

 

[Jimmy1772]

I liked the post since it works. I did write it to use it without the file opened, but that meant I had to keep closing and reopening a hidden version of excel - which was also too slow. So I accepted I will not do that update from a hidden version of excel and a little screen flashing is acceptable.