Excel VBA 按关键词搜索指定列并粘贴到目标表对应列的实现问题

核心错误点 #

• 原自定义代码处理Services数据时，将resultrow重置为1，导致匹配结果从Sheet2首行开始写入
• 搜索列、粘贴列索引与需求不匹配，且未限制最大扫描行为200
• 两次遍历Sheet1数据，执行效率较低

符合需求的完整VBA代码 #

Option Explicit
Sub CopyMatchData()
    ' 定义常量：搜索最大行、Sheet2起始粘贴行
    Const MAX_SCAN_ROW = 200
    Const START_PASTE_ROW = 1 ' 可根据需求自行修改起始粘贴行
    
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim r As Long, goodsRow As Long, serviceRow As Long
    Dim t0 As Single: t0 = Timer
    
    ' 绑定工作表对象
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    ' 初始化两类数据的粘贴行计数器
    goodsRow = START_PASTE_ROW
    serviceRow = START_PASTE_ROW
    
    Application.ScreenUpdating = False
    ' 可选：清空Sheet2目标列原有历史数据
    ws2.Columns("G:H").ClearContents
    
    With ws1
        ' 遍历1到200行，符合B1:N200的范围要求
        For r = 1 To MAX_SCAN_ROW
            ' 若I列为空可提前退出遍历，不需要可删除该行直接遍历完200行
            If Len(.Cells(r, "I")) = 0 Then Exit For
            
            Select Case .Cells(r, "I").Value
                Case "Goods"
                    ' 匹配Goods时，将对应J列值写入Sheet2第7列（G列）
                    ws2.Cells(goodsRow, "G") = .Cells(r, "J").Value
                    goodsRow = goodsRow + 1
                Case "Services"
                    ' 匹配Services时，将对应J列值写入Sheet2第8列（H列）
                    ws2.Cells(serviceRow, "H") = .Cells(r, "J").Value
                    serviceRow = serviceRow + 1
            End Select
        Next r
    End With
    Application.ScreenUpdating = True
    
    ' 输出处理统计结果
    MsgBox "共扫描" & r - 1 & "行" & vbCrLf & _
           "匹配Goods：" & goodsRow - START_PASTE_ROW & "条" & vbCrLf & _
           "匹配Services：" & serviceRow - START_PASTE_ROW & "条", _
           vbInformation, "处理完成，耗时" & Format(Timer - t0, "0.00秒")
End Sub

参考示例 #

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