VBA循环匹配供应商数据异常：无法筛选指定供应商条目问题

问题描述 #

我有一份来自多家供应商的千条级价格清单（存于Data工作表），该清单定期从数据库导出，需按供应商筛选以完成定价更新等任务。通过基于Data创建的列表框选择搜索条件，要匹配Data中所有对应条目并生成Catalogue工作表，仅提取每行指定单元格的数据（忽略大量单元格以适配系统重新导入）。目前列表生成功能已实现，但匹配逻辑存在异常：匹配仅从第一个供应商条目开始遍历至列表末尾，无法仅提取所选供应商的数据；即使先对数据排序，该问题仍存在。

原错误代码 #

Private Sub SupplierData_Click()
    ListBoxValue = SupplierData.Text
        Sheets("Catalogue").Cells(2, 27).Value = ListBoxValue
    Unload Me
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim oCell As range
    Dim Match As range
    Dim i As Long
    Dim j As Long
    i = 2
    j = 0
    
    Set ws1 = ThisWorkbook.Sheets("Catalogue")
    Set ws2 = ThisWorkbook.Sheets("Data")
    Set Match = ws1.Cells(2, 27)
        
    Do While ws2.Cells(i, 1).Value <> ""
        Set oCell = ws2.range("A:A").Find(What:=Match)
        If Not oCell Is Nothing Then ws1.Cells(i, 2) = oCell.Offset(j, 0)
        If Not oCell Is Nothing Then ws1.Cells(i, 3) = oCell.Offset(j, 1)
        If Not oCell Is Nothing Then ws1.Cells(i, 4) = oCell.Offset(j, 9)
        i = i + 1
        j = j + 1
    Loop

End Sub

问题分析 #

1. Find方法使用错误：未指定After参数，每次调用都会从A列开头开始查找，只会返回第一个匹配的供应商条目，无法遍历所有符合条件的记录
2. 循环逻辑混乱：以ws2.Cells(i,1)的非空值作为循环终止条件，同时用j偏移提取数据，本质是从第一个匹配项开始向下取行，而非筛选所有匹配目标供应商的记录
3. 未处理多匹配场景：没有利用FindNext实现循环查找，无法获取Data中所有符合条件的供应商数据

修正后的代码 #

Private Sub SupplierData_Click()
    Dim targetSupplier As String
    ' 获取选中的供应商名称
    targetSupplier = SupplierData.Text
    ThisWorkbook.Sheets("Catalogue").Cells(2, 27).Value = targetSupplier
    Unload Me
    
    Dim wsData As Worksheet
    Dim wsCatalogue As Worksheet
    Dim firstMatch As Range
    Dim currentMatch As Range
    Dim outputRow As Long
    
    ' 初始化工作表对象
    Set wsData = ThisWorkbook.Sheets("Data")
    Set wsCatalogue = ThisWorkbook.Sheets("Catalogue")
    ' 初始化输出起始行（Catalogue的第2行）
    outputRow = 2
    
    ' 清除Catalogue原有数据（保留表头）
    wsCatalogue.Range("A2:D" & wsCatalogue.Cells(wsCatalogue.Rows.Count, "A").End(xlUp).Row).ClearContents
    
    ' 查找第一个匹配的供应商，精确匹配整单元格内容
    Set firstMatch = wsData.Range("A:A").Find(What:=targetSupplier, LookIn:=xlValues, LookAt:=xlWhole)
    
    If Not firstMatch Is Nothing Then
        Set currentMatch = firstMatch
        ' 循环遍历所有匹配项
        Do
            ' 提取指定单元格数据到Catalogue
            wsCatalogue.Cells(outputRow, 2).Value = currentMatch.Value 'A列数据
            wsCatalogue.Cells(outputRow, 3).Value = currentMatch.Offset(0, 1).Value 'B列数据
            wsCatalogue.Cells(outputRow, 4).Value = currentMatch.Offset(0, 9).Value 'J列数据
            ' 输出行下移
            outputRow = outputRow + 1
            ' 查找下一个匹配项
            Set currentMatch = wsData.Range("A:A").FindNext(After:=currentMatch)
            ' 防止循环回到第一个匹配项时死循环
        Loop While Not currentMatch Is Nothing And currentMatch.Address <> firstMatch.Address
    End If
End Sub

关键修改说明 #

• 使用LookAt:=xlWhole确保精确匹配供应商名称，避免部分匹配导致的错误
• 用FindNext循环遍历所有符合条件的记录，确保不遗漏任何目标供应商数据
• 初始化时清除Catalogue原有数据，避免新旧数据混杂
• 使用outputRow独立控制输出行，与Data工作表的行号解绑，逻辑更清晰
• 添加循环终止判断，防止因FindNext回到第一个匹配项导致死循环

内容的提问来源于stack exchange，提问作者Timbo