使用For循环提取重复BP/BP Code对应数据的VBA问题

需求：从"data"工作表中，根据"Search Data"工作表里的BP和BP Code，提取所有匹配记录的Part number、Entry Date等字段到辅助表。现有代码仅返回第一条匹配记录，需修改以获取全部匹配项。

示例数据 #

BP                 BP Code     Part number      Entry Date
Wess               BP0001      123534           6/18/2024
Dupl               BP0003      11123            6/18/2024
Wess               BP0001      113              6/01/2024
Wess               BP0001      23123            1/01/2022
SSm                BP0002      12223            1/01/2022

现有问题代码 #

Sub match_Data()

Dim rSH As Worksheet
Dim sSh As Worksheet
Set rSH = ThisWorkbook.Sheets("data")
Set sSh = ThisWorkbook.Sheets("Search Data")

Dim Bpartner As String, Pcode As String

  For a = 2 To sSh.Range("A" & Rows.Count).End(xlUp).Row
    Bpartner = sSh.Range("A" & a).Value
    Pcode = sSh.Range("B" & a).Value
    
    For b = 2 To rSH.Range("AQ" & Rows.Count).End(xlUp).Row
      If rSH.Range("AQ" & b).Value = Bpartner And rSH.Range("AP" & b).Value = Pcode Then
            
        sSh.Range("C" & a).Value = rSH.Range("AS" & b).Value
        sSh.Range("D" & a).Value = rSH.Range("AI" & b).Value
        sSh.Range("E" & a).Value = rSH.Range("AV" & b).Value
        sSh.Range("F" & a).Value = rSH.Range("AZ" & b).Value
        sSh.Range("G" & a).Value = rSH.Range("BA" & b).Value
            
        Exit For ' 找到第一条匹配就退出循环，导致只返回第一条
      End If
    Next b
  Next a

End Sub

问题原因 #

代码中的Exit For语句会在找到第一个匹配项后立即终止内层循环，因此只能获取到第一条匹配记录，无法遍历所有符合条件的条目。

修改后的代码 #

Sub match_Data()

Dim rSH As Worksheet
Dim sSh As Worksheet
Set rSH = ThisWorkbook.Sheets("data")
Set sSh = ThisWorkbook.Sheets("Search Data")

Dim Bpartner As String, Pcode As String
Dim writeRow As Long ' 用于跟踪辅助表的写入行号

' 清空辅助表原有数据（表头保留，从第2行开始）
sSh.Range("C2:G" & sSh.Rows.Count).ClearContents

writeRow = 2 ' 初始写入行设为第2行

For a = 2 To sSh.Range("A" & Rows.Count).End(xlUp).Row
    Bpartner = sSh.Range("A" & a).Value
    Pcode = sSh.Range("B" & a).Value
    
    For b = 2 To rSH.Range("AQ" & Rows.Count).End(xlUp).Row
        If rSH.Range("AQ" & b).Value = Bpartner And rSH.Range("AP" & b).Value = Pcode Then
            ' 将匹配记录写入辅助表的当前writeRow行
            sSh.Range("C" & writeRow).Value = rSH.Range("AS" & b).Value
            sSh.Range("D" & writeRow).Value = rSH.Range("AI" & b).Value
            sSh.Range("E" & writeRow).Value = rSH.Range("AV" & b).Value
            sSh.Range("F" & writeRow).Value = rSH.Range("AZ" & b).Value
            sSh.Range("G" & writeRow).Value = rSH.Range("BA" & b).Value
            
            ' 写入后行号自增，准备下一条记录
            writeRow = writeRow + 1
            ' 移除Exit For，继续遍历寻找其他匹配项
        End If
    Next b
Next a

End Sub

改动说明 #

1. 移除Exit For：让内层循环完整遍历所有数据行，找到所有符合BP和BP Code匹配的记录
2. 新增writeRow变量：避免固定使用a行导致覆盖，每次写入后自增行号，确保每条匹配记录都写入新行
3. 清空原有数据：添加了清空辅助表C到G列数据的代码，避免旧数据干扰新结果（可根据需求保留或删除）

运行修改后的代码后，"Search Data"工作表会输出所有匹配的记录，比如Wess/BP0001的三条记录都会被提取出来。

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