如何实现行不固定时跨工作簿复制同表头多表对应数据？

问题背景 #

• 源Workbook指定Worksheet包含多个小表格，每个表格A列是相同表头标签，B列及以后为数据
• 目标Workbook指定Worksheet的结构、表头标签、区域名与源完全一致，但无数据
• 源数据行位置不固定，固定行复制方法失效，现有VBA代码无法完成对应数据复制

现有无效代码 #

'Sub CopyTablesData()
Dim srcWorkbook As Workbook
Dim destWorkbook As Workbook
Dim srcSheet As Worksheet
Dim destSheet As Worksheet
Dim srcRange As Range
Dim destRange As Range
Dim lastRow As Long
Dim lastCol As Long
Dim tableStart As Range
Dim tableEnd As Range

' Set the workbooks
Set srcWorkbook = Workbooks("Test Sour.xlsm")
Set destWorkbook = Workbooks("Test Dest.xlsx")

' Loop through each sheet in the source workbook
For Each srcSheet In srcWorkbook.Sheets
    ' Set the corresponding sheet in the destination workbook
    Set destSheet = destWorkbook.Sheets("Summary")
    
    ' Find the first cell with data in the source sheet
    Set tableStart = srcSheet.Cells.Find(What:="*", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
    
    ' Find the last cell with data in the source sheet
    Set tableEnd = srcSheet.Cells.Find(What:="*", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    
    ' Check if any data is found
    If Not tableStart Is Nothing And Not tableEnd Is Nothing Then
        ' Set the range for the source table
        Set srcRange = srcSheet.Range(tableStart, tableEnd)
        
        ' Set the range for the destination table
        Set destRange = destSheet.Range(tableStart.Address, tableEnd.Address)
        
        ' Copy the data from the source to the destination
        srcRange.Copy Destination:=destRange
    End If
Next srcSheet

' Notify the user that the process is complete
MsgBox "Data copied successfully!"
'End Sub

解决方案代码 #

核心逻辑：遍历目标工作表的所有表头标签，在源工作表中精确匹配对应表头，复制该表头下的B列及以后数据到目标位置。

Sub CopyMatchedData()
    Dim srcWB As Workbook, destWB As Workbook
    Dim srcWS As Worksheet, destWS As Worksheet
    Dim destHeader As Range, srcHeader As Range
    Dim lastDataRow As Long, lastDataCol As Long
    
    ' 自定义指定工作表名称（根据实际情况修改）
    Const SRC_SHEET_NAME As String = "SourceSheet" ' 源文件中需处理的工作表
    Const DEST_SHEET_NAME As String = "Summary" ' 目标文件中需处理的工作表
    
    ' 绑定已打开的工作簿
    Set srcWB = Workbooks("Test Sour.xlsm")
    Set destWB = Workbooks("Test Dest.xlsx")
    Set srcWS = srcWB.Sheets(SRC_SHEET_NAME)
    Set destWS = destWB.Sheets(DEST_SHEET_NAME)
    
    ' 遍历目标工作表A列的所有表头（常量单元格，即表头标签）
    For Each destHeader In destWS.Range("A:A").SpecialCells(xlCellTypeConstants)
        ' 在源工作表A列精确匹配相同表头
        Set srcHeader = srcWS.Range("A:A").Find(What:=destHeader.Value, LookIn:=xlValues, LookAt:=xlWhole)
        
        If Not srcHeader Is Nothing Then
            ' 获取当前表头对应的最后数据行和列
            lastDataRow = srcWS.Cells(srcWS.Rows.Count, srcHeader.Column).End(xlUp).Row
            lastDataCol = srcWS.Cells(srcHeader.Row, srcWS.Columns.Count).End(xlToLeft).Column
            
            ' 复制B列及以后的数据到目标工作表对应位置
            srcWS.Range(srcHeader.Offset(0, 1), srcWS.Cells(lastDataRow, lastDataCol)).Copy _
                Destination:=destWS.Range(destHeader.Offset(0, 1), destWS.Cells(lastDataRow, lastDataCol))
        End If
    Next destHeader
    
    MsgBox "数据匹配复制完成！"
End Sub

代码说明 #

• 仅处理指定的单个工作表，无需遍历所有工作表
• 通过精确匹配表头标签实现数据对应复制，不受源数据行位置变化影响
• 自动识别每个表头下的有效数据范围，只复制有数据的区域
• 若源工作表中找不到对应表头，会自动跳过该条目，避免运行报错

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