VBA如何查找A列含指定关键词的行并复制相邻列内容到指定位置

方案1：最小改动原有代码实现模糊匹配 #

只需修改原有代码的判断逻辑，使用VBA的Like运算符加通配符即可实现包含匹配，无需引入Find函数，适合新手理解和维护：

Option Compare Text ' 忽略大小写匹配，不需要区分大小写可删除本行
Sub Test()
    Dim lr As Long
    Dim r As Long
    
    ' 定位A列最后一行有数据的行号
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    
    ' 遍历A列所有行
    For r = 1 To lr
        ' 通配符*代表任意长度任意字符，只要单元格包含关键词就会匹配成功
        If Cells(r, "A") Like "*Super*" Or Cells(r, "A") Like "*Pension*" Or Cells(r, "A") Like "*SMSF*" Then
            ' 直接赋值替代复制粘贴，运行效率更高
            Cells(r, "C") = Cells(r, "B").Value
        End If
    Next r 
End Sub

方案2：使用Find方法实现（解决无限循环问题） #

Find方法出现无限循环的核心原因是：查找完全部匹配项后会自动回到第一个匹配项继续查找，只要记录第一个匹配单元格的地址，每次查找后判断是否回到初始匹配位置即可终止循环。适合数据量较大的场景，运行效率高于逐行遍历：

Option Compare Text ' 忽略大小写匹配，不需要区分大小写可删除本行
Sub TestWithFind()
    Dim searchRng As Range
    Dim foundRng As Range
    Dim firstAddr As String
    Dim keyWords As Variant
    Dim kw As Variant
    
    ' 定义待匹配关键词
    keyWords = Array("Super", "Pension", "SMSF")
    ' 限定查找范围为A列有数据的区域
    Set searchRng = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
    
    ' 遍历每个关键词查找
    For Each kw In keyWords
        Set foundRng = searchRng.Find(what:=kw, LookIn:=xlValues, lookat:=xlPart)
        ' 找到匹配项时进入处理逻辑
        If Not foundRng Is Nothing Then
            ' 记录第一个匹配项的地址，作为循环终止的判断依据
            firstAddr = foundRng.Address
            Do
                ' 将同行B列内容赋值到C列
                foundRng.Offset(0, 2) = foundRng.Offset(0, 1).Value
                ' 查找下一个匹配项
                Set foundRng = searchRng.FindNext(foundRng)
            ' 当查找回到第一个匹配项时终止循环，避免无限运行
            Loop Until foundRng.Address = firstAddr
        End If
    Next kw
End Sub

注意事项 #

• 两种方案都支持单元格包含关键词的模糊匹配，可识别类似"super consolidator"这类包含关键词的内容
• 数据量小于1万行时建议使用方案1，逻辑更简单不易出错；数据量更大时选择方案2效率更高
• 不需要忽略大小写匹配时，删除代码顶部的Option Compare Text即可

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