如何用Excel VBA宏按Sheet2保险号批量匹配Sheet1对应数据并粘贴

可动态遍历匹配的VBA实现代码 #

你录制的宏为固定单元格、固定筛选值的手动操作记录，将逻辑调整为动态遍历保险号、自动定位粘贴位置即可实现需求，代码如下：

Sub Insurance_Check()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastSourceRow As Long, i As Long, pasteRow As Long
    Dim insNum As String
    
    ' 绑定工作表对象，无需来回切换工作表
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsTarget = ThisWorkbook.Sheets("Sheet2")
    ' 自动获取Sheet1数据最大行号，无需手动写死范围
    lastSourceRow = wsSource.Cells(Rows.Count, "K").End(xlUp).Row
    ' 粘贴起始行，可根据你需要的粘贴起始位置调整，原录制宏从E6开始可改为6
    pasteRow = 1
    
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    ' 清空已有筛选
    If wsSource.AutoFilterMode Then wsSource.AutoFilterMode = False
    
    ' 遍历Sheet2 A列1-500行的所有保险号
    For i = 1 To 500
        insNum = Trim(wsTarget.Cells(i, "A").Value)
        ' 跳过空单元格
        If insNum <> "" Then
            ' 按当前保险号筛选Sheet1第11列（K列）
            wsSource.Range("A2:K" & lastSourceRow).AutoFilter Field:=11, Criteria1:=insNum
            ' 复制筛选后的可见有效数据
            wsSource.Range("A3:K" & lastSourceRow).SpecialCells(xlCellTypeVisible).Copy
            ' 粘贴到Sheet2 E列的空行位置
            wsTarget.Cells(pasteRow, "E").PasteSpecial Paste:=xlPasteAll
            ' 更新下一次粘贴的起始行
            pasteRow = pasteRow + wsSource.Range("A3:K" & lastSourceRow).SpecialCells(xlCellTypeVisible).Rows.Count
            Application.CutCopyMode = False
        End If
    Next i
    
    ' 恢复环境设置
    If wsSource.AutoFilterMode Then wsSource.AutoFilterMode = False
    Application.ScreenUpdating = True
    MsgBox "所有保险号匹配完成"
End Sub

调整说明 #

• 若保险号在Sheet1的列位不是K列，可修改Field:=11为对应列的序号
• 若不需要从Sheet2的E1行开始粘贴，修改pasteRow = 1为对应起始行号即可
• 运行前建议备份文件，避免数据误覆盖

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