VBA宏求助：匹配表头后将日报数据粘贴至数据库工作簿对应列末行

先给你指出原代码里的核心问题，再给你改好的完整代码：

原代码的关键错误 #

• 数据流向完全搞反：需求是从"DAILY REPORT"复制数据到目标工作簿，但原代码是把目标表的内容复制回日报表了
• 找最后一行的方法错误：用CountA+End(xlDown)会因为中间的空白行漏统计数据，应该从列底往上找最后有数据的行
• 依赖Activate/Select操作：这种方式很容易因为工作表切换出问题，应该直接用对象引用操作工作表
• 未保存目标工作簿：原代码关闭时设的savechanges:=False，等于白做了修改
• 表头计数未指定工作表：head_count的Range没关联wsCopy，如果当前激活的不是日报表，会取错表头数量

修正后的完整代码 #

Sub Submit()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim wbTarget As Workbook
    Dim sourceHeadCount As Integer
    Dim targetColCount As Integer
    Dim i As Integer
    Dim j As Integer
    Dim lastSourceRow As Long
    Dim lastTargetRow As Long
    
    ' 关闭屏幕刷新提升运行速度
    Application.ScreenUpdating = False
    
    ' 绑定源工作表（当前工作簿的DAILY REPORT）
    Set wsSource = ThisWorkbook.Sheets("DAILY REPORT")
    ' 统计源表的表头列数
    sourceHeadCount = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
    
    ' 打开目标工作簿并绑定目标工作表
    Set wbTarget = Workbooks.Open("Y:\Daily_Yield&Production_Report.2\FREEPORT_PRO_YIELD_DAILY_REPORT\PLT-1-2-3_PYDR.xlsm")
    Set wsTarget = wbTarget.Sheets("PLT-1")
    ' 统计目标表的表头列数
    targetColCount = wsTarget.Cells(1, wsTarget.Columns.Count).End(xlToLeft).Column
    
    ' 遍历源表的每个表头
    For i = 1 To sourceHeadCount
        ' 获取当前源表头的文本
        Dim sourceHeader As String
        sourceHeader = wsSource.Cells(1, i).Text
        
        ' 遍历目标表的表头找匹配项
        For j = 1 To targetColCount
            If wsTarget.Cells(1, j).Text = sourceHeader Then
                ' 找到源表当前列的最后一行数据
                lastSourceRow = wsSource.Cells(wsSource.Rows.Count, i).End(xlUp).Row
                ' 找到目标表当前列的最后空白行（最后有数据行+1）
                lastTargetRow = wsTarget.Cells(wsTarget.Rows.Count, j).End(xlUp).Row + 1
                
                ' 复制源表数据（从第2行到最后一行，跳过表头）
                wsSource.Range(wsSource.Cells(2, i), wsSource.Cells(lastSourceRow, i)).Copy
                ' 粘贴到目标表的最后空白行
                wsTarget.Cells(lastTargetRow, j).PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                
                ' 找到匹配项后跳出当前循环，不用继续找其他列
                Exit For
            End If
        Next j
    Next i
    
    ' 保存并关闭目标工作簿
    wbTarget.Close savechanges:=True
    
    ' 回到源表
    wsSource.Activate
    wsSource.Cells(1, 1).Select
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
End Sub

关键修正点说明 #

1. 对象绑定：用Set直接绑定源/目标工作表、工作簿，完全避免Activate/Select，不会因为工作表切换出错
2. 正确找最后一行：用Cells(Rows.Count, 列号).End(xlUp).Row，不管中间有没有空白行，都能准确找到最后有数据的行
3. 数据流向修正：从源表（DAILY REPORT）复制数据，粘贴到目标表（PLT-1）对应列的最后空白行
4. 保存设置：关闭目标工作簿时设savechanges:=True，确保修改被保存
5. 表头遍历逻辑：找到匹配的表头列后直接Exit For，减少不必要的循环
6. 跳过表头复制：源表从第2行开始复制，避免把表头重复粘贴到目标表

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