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 5/4/2022. 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

CodePudding user response：

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.

CodePudding user response：

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