Excel VBA 同列搜索两个关键词按规则复制数据到另一工作表

修正后可直接运行的VBA代码 #

Sub CopyCells()
    Dim sht1 As Worksheet, sht2 As Worksheet
    Dim searchRange As Range
    Dim i As Long, pasteRow As Long
    Dim searchKeywords As Variant, keyword As Variant
    
    ' 绑定工作表对象，避免硬编码序号出错
    Set sht1 = ThisWorkbook.Worksheets("Sheet1")
    Set sht2 = ThisWorkbook.Worksheets("Sheet2")
    ' 按需求设定搜索关键词顺序：先Goods后Services
    searchKeywords = Array("Goods", "Services")
    ' 限定搜索范围为指定的B1:N200区域
    Set searchRange = sht1.Range("B1:N200")
    
    ' 初始化粘贴起始行：对应Sheet2的B3行所在行号
    pasteRow = 3
    
    ' 按顺序遍历两个关键词执行搜索
    For Each keyword In searchKeywords
        ' 遍历搜索范围的所有行
        For i = 1 To searchRange.Rows.Count
            ' 匹配当前行第8列（I列）的关键词
            If searchRange.Cells(i, 8).Value = keyword Then
                ' Sheet1 C列（搜索范围第2列）仅粘贴数值到Sheet2第3列
                sht2.Cells(pasteRow, 3).Value = searchRange.Cells(i, 2).Value
                ' Sheet1 F列（搜索范围第5列）带格式粘贴到Sheet2第4列
                searchRange.Cells(i, 5).Copy
                sht2.Cells(pasteRow, 4).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
                Application.CutCopyMode = False
                ' 粘贴行号自增，下一条数据自动顺延
                pasteRow = pasteRow + 1
            End If
        Next i
    Next keyword
End Sub

核心调整说明 #

• 用关键词数组按顺序遍历，自动实现先搜索Goods、再搜索Services的逻辑，无需重复写两次循环
• 固定搜索范围为B1:N200，符合需求的范围限制
• 用pasteRow变量统一控制粘贴位置：初始值为3对应B3起始位置，每粘贴一条数据自动+1，自动实现Services结果接续在Goods结果之后
• 分别处理两列的粘贴规则：C列直接赋值实现仅粘贴数值，F列用PasteSpecial实现带格式粘贴
• 移除了原代码中冗余的双层循环，运行效率更高

效果示意 #

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