如何编写VBA脚本实现跨表多源数据按行匹配批量复制粘贴

实现逻辑 #

• 自动识别初始列表的连续有效数据行数，无需手动指定行号参数，适配任意规模的数据源
• 自动统计位置列表的所有待填充位置区块
• 采用批量复制逻辑提升运行效率，自带错误捕获和运行结果提示

完整VBA代码 #

Sub 批量填充数据到位置列表()
    ' ====== 以下参数可根据自己的表格实际结构修改 ======
    Const SOURCE_SHEET_NAME As String = "初始列表"   ' 数据源工作表名称
    Const TARGET_SHEET_NAME As String = "位置列表"   ' 待填充位置工作表名称
    Const SOURCE_HEADER_ROW As Long = 1             ' 初始列表表头所在行号
    Const EACH_POSITION_ROW_COUNT As Long = 6       ' 位置列表每个位置块占用的固定行数
    Const TARGET_START_ROW As Long = 2              ' 位置列表第一个位置块的起始行号
    Const LAST_DATA_COL As String = "Z"             ' 初始列表最后一列数据的列标
    ' ==============================================

    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim sourceLastRow As Long, targetLastRow As Long
    Dim i As Long, positionCount As Long, currentTargetRow As Long
    
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    On Error GoTo ErrorHandler

    ' 绑定工作表
    Set wsSource = ThisWorkbook.Worksheets(SOURCE_SHEET_NAME)
    Set wsTarget = ThisWorkbook.Worksheets(TARGET_SHEET_NAME)

    ' 自动识别初始列表有效数据最大行（默认按A列非空判断）
    sourceLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    If sourceLastRow <= SOURCE_HEADER_ROW Then
        MsgBox "初始列表未检测到有效数据，请检查后重试", vbExclamation
        GoTo CleanUp
    End If

    ' 自动统计位置列表总共有多少个待填充位置块
    targetLastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
    positionCount = WorksheetFunction.Ceiling((targetLastRow - TARGET_START_ROW + 1) / EACH_POSITION_ROW_COUNT, 1)
    If positionCount < 1 Then
        MsgBox "位置列表未检测到有效位置区间，请检查后重试", vbExclamation
        GoTo CleanUp
    End If

    ' 遍历所有位置块填充数据
    currentTargetRow = TARGET_START_ROW
    For i = 1 To positionCount
        wsSource.Range("A" & SOURCE_HEADER_ROW + 1 & ":" & LAST_DATA_COL & sourceLastRow).Copy _
            Destination:=wsTarget.Cells(currentTargetRow, "A")
        ' 偏移到下一个位置块起始行
        currentTargetRow = currentTargetRow + EACH_POSITION_ROW_COUNT
    Next i

    MsgBox "填充完成！共处理" & (sourceLastRow - SOURCE_HEADER_ROW) & "条有效数据，填充至" & positionCount & "个位置区间", vbInformation

CleanUp:
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.CutCopyMode = False
    Exit Sub

ErrorHandler:
    MsgBox "运行出错，错误信息：" & Err.Description, vbCritical
    Resume CleanUp
End Sub

使用说明 #

• 如果初始列表的有效数据识别列不是A列，把代码中判断有效行对应的"A"改成实际使用的列标即可
• 运行前务必备份原文件，避免误操作导致数据丢失

运行操作：打开Excel文件后按Alt+F11调出VBA编辑器，右键点击左侧当前工作簿名称选择「插入」-「模块」，把代码粘贴到模块代码窗口后按F5即可执行。

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