如何修复VBA循环，找到所有Label对应的全部匹配项？

问题说明 #

在工作表「C7BB2HD3IINA_NRM_X302」中查找所有文本「KENNFELD」，将每个匹配项右侧单元格内容作为目标值，在工作簿其他工作表中查找该目标值的所有匹配项。当前代码仅能识别第一个目标值的匹配结果，遗漏了其余6个匹配项。

原代码 #

Dim helpc As Range
Dim label As Range
Dim firstAddress As String
Dim foundCell As Range

With Sheets("C7BB2HD3IINA_NRM_X302")
Set helpc = .Cells.Find(what:="KENNFELD", MatchCase:=True)
Set label = helpc.Offset(0, 1) ' assign the value of the cell to label
If Not helpc Is Nothing Then
    firstAddress = helpc.Address
    Do
        For Each ws In ThisWorkbook.Sheets
            If ws.Name <> "C7BB2HD3IINA_NRM_X302" Then
                Set foundCell = ws.Cells.Find(what:=label.Value, LookIn:=xlValues, LookAt:=xlWhole, _
                                              MatchCase:=True)
                If Not foundCell Is Nothing Then
                    MsgBox "Label " & label.Value & " found on sheet " & ws.Name
                End If
            End If
        Next ws
        Set helpc = .Cells.FindNext(helpc)
    Loop While Not helpc Is Nothing And helpc.Address <> firstAddress
End If
End With

问题根源 #

1. 目标值未循环更新：原代码仅在循环外给label赋值一次，后续通过FindNext找到新的「KENNFELD」时，label始终指向第一个匹配项的右侧单元格，导致全程只查找同一个目标值。
2. 单工作表仅查第一个匹配项：在其他工作表中使用Find时，只获取了第一个匹配结果，未遍历当前工作表内的所有匹配项。

修复后的代码 #

Dim helpc As Range
Dim targetValue As String
Dim firstKennfeldAddr As String
Dim foundCell As Range
Dim firstFoundAddr As String

With Sheets("C7BB2HD3IINA_NRM_X302")
    ' 定位第一个KENNFELD
    Set helpc = .Cells.Find(what:="KENNFELD", MatchCase:=True)
    If Not helpc Is Nothing Then
        firstKennfeldAddr = helpc.Address
        Do
            ' 更新当前KENNFELD对应的目标值
            targetValue = helpc.Offset(0, 1).Value
            
            ' 遍历工作簿内其他工作表
            For Each ws In ThisWorkbook.Sheets
                If ws.Name <> "C7BB2HD3IINA_NRM_X302" Then
                    ' 查找当前工作表内第一个匹配项
                    Set foundCell = ws.Cells.Find(what:=targetValue, LookIn:=xlValues, _
                                                  LookAt:=xlWhole, MatchCase:=True)
                    If Not foundCell Is Nothing Then
                        firstFoundAddr = foundCell.Address
                        Do
                            ' 输出匹配项位置信息
                            MsgBox "Label " & targetValue & " found on sheet " & ws.Name & " at " & foundCell.Address
                            ' 查找当前工作表下一个匹配项
                            Set foundCell = ws.Cells.FindNext(foundCell)
                        Loop While Not foundCell Is Nothing And foundCell.Address <> firstFoundAddr
                    End If
                End If
            Next ws
            
            ' 查找下一个KENNFELD
            Set helpc = .Cells.FindNext(helpc)
        Loop While Not helpc Is Nothing And helpc.Address <> firstKennfeldAddr
    End If
End With

修复要点 #

• 每次找到新的「KENNFELD」后，重新获取其右侧单元格的目标值，确保循环处理所有需要查找的内容。
• 在每个目标工作表中添加内层循环，通过FindNext遍历当前工作表内的所有匹配项，避免遗漏。
• 将label改为字符串变量targetValue，减少Range引用带来的潜在问题，逻辑更清晰。

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