基于表头匹配的Excel VBA脚本修改：转置追加数据不覆盖

你原先的VBA脚本是固定区域复制转置到指定位置，现在需要改成按表头匹配（Sheet1的A列表头对应Sheet2第13行的表头），并且每次运行自动把数据追加到Sheet2的下一行，不会覆盖已有内容。

以下是修改后的完整代码：

Sub CopyToSheetByHeader()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim sourceHeaders As Range, targetHeaders As Range
    Dim sourceCell As Range, targetCell As Range
    Dim lastRowTarget As Long
    
    ' 指定源表和目标表
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    Set wsTarget = ThisWorkbook.Worksheets("Excel A&P")
    
    ' 定义源表头区域（Sheet1的A13:A23，对应原脚本中数据的表头列）
    ' 若实际表头位置不同，可直接调整这个Range
    Set sourceHeaders = wsSource.Range("A13:A23")
    ' 定义目标表头区域（Sheet2的第13行，从B列到Excel最大列）
    Set targetHeaders = wsTarget.Rows(13).Range("B1:XFD1")
    
    ' 计算目标表的下一个空行：找到B列最后一行有数据的行，再加1
    lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, "B").End(xlUp).Row
    ' 如果B列无数据，从第14行开始（对应原脚本的起始行）
    If lastRowTarget < 14 Then lastRowTarget = 14 Else lastRowTarget = lastRowTarget + 1
    
    ' 遍历每个源表头，匹配目标表头后粘贴对应数据
    For Each sourceCell In sourceHeaders
        ' 精确匹配目标表头中的内容
        Set targetCell = targetHeaders.Find(What:=sourceCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not targetCell Is Nothing Then
            ' 将Sheet1对应行的B列数据粘贴到目标列的空行
            wsSource.Cells(sourceCell.Row, "B").Copy
            wsTarget.Cells(lastRowTarget, targetCell.Column).PasteSpecial Paste:=xlPasteValues
        End If
    Next sourceCell
    
    ' 清空剪贴板，避免残留提示
    Application.CutCopyMode = False
    MsgBox "数据已成功追加！"
End Sub

关键修改说明 #

• 表头匹配逻辑：用Find方法精准匹配Sheet1 A列表头与Sheet2第13行的表头，不管表头顺序是否一致，都能把数据放到对应列
• 自动追加行：通过End(xlUp)定位目标表最后一行数据，自动计算下一个空行，彻底避免覆盖已有内容
• 值粘贴设置：默认只粘贴数据值，避免格式冲突；如果需要保留原格式，把xlPasteValues改成xlPasteAll即可
• 容错处理：如果某个表头在目标表中找不到，会跳过该列，不会触发报错

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