Excel VBA/VLOOKUP同项目多结果返回 如何提取xls全部车型匹配值

修改思路 #

• 将原来返回单个车型的FindCarModel函数改造为返回字符串数组，存储所有匹配到的车型结果
• 使用Find + FindNext组合遍历工作表内所有包含MODEL:的单元格，避免仅返回第一个匹配项
• 主流程中遍历返回的车型数组，逐个写入目标工作表，适配单文件多车型的场景

完整修改后代码 #

' 原主流程修改后
For Each File In Folder.Files
    DoEvents
    Set xlBook = xlApp.Workbooks.Open(File, False)
    Set xlSheet = xlBook.Sheets(1)

    On Error Resume Next
    
    ' 调用修改后的函数返回所有车型
    Dim allModels As Variant
    allModels = FindAllCarModel(xlSheet)
    
    ' 遍历所有车型写入目标表
    If IsArray(allModels) Then
        Dim m As Integer
        For m = LBound(allModels) To UBound(allModels)
            ThisWorkbook.Worksheets("T_G").Cells(n, 1) = allModels(m)
            n = n + 1
        Next m
    End If
        
    xlBook.Close False
    Set xlBook = Nothing
Next

End Sub

' 改造后的查找所有车型函数
Private Function FindAllCarModel(ws As Worksheet) As Variant
    Dim EncontraString As String
    Dim Intervalo As Range
    Dim firstFindAddr As String
    Dim i As Integer
    Dim resultArr() As String
    Dim arrIndex As Integer
    
    EncontraString = "MODEL:"
    arrIndex = 0
    ReDim resultArr(0 To 1000) ' 预开数组空间，可根据实际单文件最大车型数调整
    
    With ws.Range("A:IV")
        Set Intervalo = .Find(What:=EncontraString, _
                           After:=.Cells(1), _
                           LookIn:=xlValues, _
                           LookAt:=xlPart, _
                           SearchOrder:=xlByRows, _
                           SearchDirection:=xlNext, _
                           MatchCase:=False)
                           
        ' 找到匹配项后循环查找所有结果
        If Not Intervalo Is Nothing Then
            firstFindAddr = Intervalo.Address ' 记录第一个匹配项地址避免无限循环
            Do
                ' 提取当前匹配行右侧首个非空值
                i = Intervalo.Column + 1
                Do While ws.Cells(Intervalo.Row, i) = ""
                    i = i + 1
                Loop
                resultArr(arrIndex) = ws.Cells(Intervalo.Row, i)
                arrIndex = arrIndex + 1
                
                ' 查找下一个匹配项
                Set Intervalo = .FindNext(Intervalo)
            Loop While Not Intervalo Is Nothing And Intervalo.Address <> firstFindAddr
        End If
    End With
    
    ' 处理返回结果
    If arrIndex > 0 Then
        ReDim Preserve resultArr(0 To arrIndex - 1)
        FindAllCarModel = resultArr
    Else
        FindAllCarModel = Empty ' 无匹配项返回空
    End If
End Function

关键改动说明 #

• 查找方向调整：将原SearchDirection:=xlPrevious改为xlNext，从工作表头部开始顺序查找所有匹配项
• 防重复循环：记录第一个匹配到的单元格地址，当FindNext回到首个地址时终止查找，避免无限循环
• 数组存储结果：用动态数组存储所有匹配到的车型，最后裁剪数组长度后返回
• 主流程适配：新增数组遍历逻辑，单文件内所有车型会按查找顺序逐行写入T_G表，行号自动累加

内容的提问来源于stack exchange，提问作者L.Mene