VLOOKUP the same item with multiple results

Question

Every day I receive several.xls containing information about a particular item, for example, a car.

I developed this macro in which I don't need to open all the files because the macro imports all the data I need.

For Each File In Folder.Files
    DoEvents
    Set xlBook = xlApp.Workbooks.Open(File, False)
    Set xlSheet = xlBook.Sheets(1)

    On Error Resume Next
    
    Do
        ws.Cells(i, 1) = FindCarModel(xlSheet) 'MODEL:
    Loop While xlSheet.Cells(j, rngQTE.Column) <> ""
        
    ThisWorkbook.Worksheets("T_G").Cells(n, 1) = FindCarModel(xlSheet)

    n = n + 1
    xlBook.Close False
    Set xlBook = Nothing
Next

End Sub

Private Function FindCarModel(ws As Worksheet) As String
Dim EncontraString As String
Dim Intervalo As Range
Dim i As Integer

EncontraString = "MODEL:"
With ws.Range("A:IV")
    Set Intervalo = .Find(What:=EncontraString, _
                               After:=.Cells(1), _
                               LookIn:=xlValues, _
                               LookAt:=xlPart, _
                               SearchOrder:=xlByRows, _
                               SearchDirection:=xlPrevious, _
                               MatchCase:=False)

    If Not Intervalo Is Nothing Then
        i = Intervalo.Column + 1
        Do While ws.Cells(Intervalo.Row, i) = ""
            i = i + 1
        Loop
        FindCarModel = ws.Cells(Intervalo.Row, i)
    End If
End With

End Function

The macro searches for the word "model" and pastes the value of the first cell to the right.

I am no longer receiving files with a single "car model".

How can I return all the car models inside the xls and not just the first one found.

Answer 1

Use FindNext

Option Explicit

Sub FindAll()
    
    Dim fso As Object, ts As Object, folder, file
    Dim wb As Workbook, ws As Worksheet, result As Collection
    Dim xlBook As Workbook, xlSheet As Worksheet
    Dim r As Long, n As Integer

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("T_G")

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.getfolder("path-to-files")

    r = 1
    For Each file In folder.Files
        
        Set xlBook = Workbooks.Open(file, False, True) ' read only
        Set xlSheet = xlBook.Sheets(1)
        Set result = FindCarModel(xlSheet) 'MODEL:
        xlBook.Close False
        Set xlBook = Nothing

        For n = 1 To result.Count
           r = r + 1
           ws.Cells(r, 1) = result.Item(n)
        Next
        
    Next
    MsgBox r & " Items found"
End Sub

Private Function FindCarModel(ws As Worksheet) As Collection

    Const EncontraString = "MODEL:"
    Dim Intervalo As Range, i As Integer, sFirstFind As String
    Dim result As New Collection

    With ws.Range("A:IV")
        Set Intervalo = .Find(What:=EncontraString, _
                            After:=.Cells(1), _
                            LookIn:=xlValues, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False)
        If Not Intervalo Is Nothing Then
            sFirstFind = Intervalo.Address
            Do
                 i = Intervalo.Column + 1
                 Do While ws.Cells(Intervalo.Row, i) = ""
                    i = i + 1
                 Loop
                 result.Add ws.Cells(Intervalo.Row, i).Value2
                 Set Intervalo = .FindNext(Intervalo)
            Loop While Intervalo.Address <> sFirstFind
        End If
    End With
    Set FindCarModel = result
End Function