Excel VBA匹配到多个相同数据时如何实现循环填充？

解决方案 #

你原代码的问题在于Find方法默认仅返回第一个匹配的单元格，要覆盖所有匹配项，只需在原有基础上增加FindNext循环逻辑即可，不需要复杂的数组操作，修改后的代码如下：

Sub Test_match_fill_data()
    Dim firstMatchAddr As String
    Dim aCell
    Dim e As Long, k As Long, matchrow As Long
    Dim w1 As Worksheet, w2 As Worksheet
    Dim findRng As Range
    
    Set w1 = Workbooks("Book1").Sheets("Sheet1")
    Set w2 = Workbooks("Book2").Sheets("Sheet2")
    
    e = w1.Cells(w1.Rows.Count, 1).End(xlUp).Row
    k = w2.Cells(w2.Rows.Count, 1).End(xlUp).Row
    
    For Each aCell In w1.Range("A2:A" & e)
        ' 清空上一轮的查找结果
        Set findRng = Nothing
        ' 查找第一个匹配项
        Set findRng = w2.Columns("A:A").Find(What:=Left$(aCell.Value, 6) & "*", LookAt:=xlWhole)
        
        If Not findRng Is Nothing Then
            ' 记录第一个匹配项的地址，用于判断循环是否结束
            firstMatchAddr = findRng.Address
            Do
                ' 填充当前匹配行的B列
                w2.Range("B" & findRng.Row).Value = aCell.Offset(0, 1).Value
                ' 查找下一个匹配项
                Set findRng = w2.Columns("A:A").FindNext(findRng)
            ' 当查找到回到第一个匹配项时结束循环
            Loop While Not findRng Is Nothing And findRng.Address <> firstMatchAddr
        End If
    Next
End Sub

关键改动说明 #

• 新增了firstMatchAddr变量记录第一个匹配项的地址，避免循环查找时无限重复
• 用FindNext持续查找后续匹配项，遍历所有符合条件的单元格
• 去掉了冗余的错误处理逻辑，直接通过判断findRng是否为空就能确认是否存在匹配项
• 修正了你原代码中变量声明的小问题：原来的Dim w1, w2 As Worksheet只会把w2声明为Worksheet类型，w1会默认是Variant类型，修改后两个变量都是明确的Worksheet类型

如果你后续熟悉数组操作后，改用数组遍历的方式在数据量很大的时候运行效率会更高，当前版本对于万行以内的数据完全够用。

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