VLOOKUP the same item with multiple results - excel

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