How to lookup multiple cells based on multiple criteria in VBA - excel

Question

I'm extremely new to VBA and have tried Googling to find what I need, but have fallen short.
I have a sheet (Sheet1) containing a list of companies that currently have, or at some point have had, a subscription. The list contains the City (Col A), the Company (Col B), the Category (Col C) and a Cancellation Date (Col D) (if applicable). What I want to do is fill in the current company for that city/category on a different sheet. I want those headers to be City (Col D), Category 1 (Col E), Category 2 (Col F), and Category 3 (Col G).
Here are images of the two sheets of test data:
Sheet 1
Sheet 2
There can only be one company per category per city. For example: in my test data, company D was under Category 1 in San Antonio, but cancelled on 11/12/2021. Then, company N took that spot in San Antonio. So, in my table on Sheet 2, I want company N to be populated. The data set I'm using this for is very large and constantly changing, so I would like an automated way to do this.
Here is a copy of the code I pieced together:
Sub CompanyLookup()
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
Dim lastRowInCity, lastRowOutCity, i, k, m As Long
Dim lookFor, j, inArray, outArray, findArray As Variant
Dim inWks, outWks As Worksheet
Set inWks = ThisWorkbook.Sheets(1)
Set outWks = ThisWorkbook.Sheets(2)
lastRowInCity = inWks.Cells(Rows.Count, "A").End(xlUp).Row
lastRowOutCity = outWks.Cells(Rows.Count, "D").End(xlUp).Row
lastRowCategory = inWks.Cells(Rows.Count, "C").End(xlUp).Row
lastRowDate = inWks.Cells(Rows.Count, "D").End(xlUp).Row
lastColCategory = outWks.Cells(Columns.Count, "D").End(xlToLeft).Column
inArray = Range(inWks.Cells(1, 1), inWks.Cells(lastRowInCity, 3))
findArray = Range(outWks.Cells(1, 4), outWks.Cells(lastRowOutCity, 4))
outArray = Range(outWks.Cells(1, 5), outWks.Cells(lastRowOutCity, 5))
On Error Resume Next
For i = 2 To lastRowOutCity
For j = 2 To lastRowInCity
For k = 2 To lastRowCategory
For m = 2 To lastRowDate
lookFor = findArray(i, 1)
If inArray(j, 1) = lookFor And inArray(m, 4) < 1 And inArray(k, 3) = outArray(lastColCategory, 1) Then
outArray(i, 1) = inArray(j, 2)
Exit For
End If
Next j
Next m
Next k
Next i
Range(outWks.Cells(1, 5), outWks.Cells(lastRowOutCity, 5)) = outArray
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

Answer 1

Assuming your data looks exactly as your screenshots:
Sub CompanyLookup()
Dim sourceData, resultData, rngSource As Range, rngResult As Range
Dim r As Long, c As Long, city As String, cat As String, rSrc As Long
Set rngSource = ThisWorkbook.Sheets(1).Range("A1").CurrentRegion
Set rngResult = ThisWorkbook.Sheets(2).Range("D1").CurrentRegion
sourceData = rngSource.Value
resultData = rngResult.Value
'scan through the results array
For r = 2 To UBound(resultData, 1)
city = resultData(r, 1) 'city
For c = 2 To UBound(resultData, 2)
cat = resultData(1, c) 'category
'Scan the source data for a city+category match,
' ignoring lines with a cancellation date
For rSrc = 2 To UBound(sourceData, 1)
If Len(sourceData(rSrc, 4)) = 0 Then 'no cancellation date
If sourceData(rSrc, 1) = city And sourceData(rSrc, 3) = cat Then
resultData(r, c) = sourceData(rSrc, 2) 'populate the company
Exit For 'done searching
End If
End If
Next rSrc
Next c
Next r
rngResult.Value = resultData 'populate the results
End Sub

Answer 2

I had exact same issue this week, and from what i read online, the fact that you cannot use vlookup or find function for multiple criteria. Mostly people prefer using .find fuction and when you find it, you can use loop to find second criteria. It was what i used.