基于列标题合并Excel至目标文件的VBA代码问题及需求

问题修复要点 #

• 原代码按列单独计算粘贴起始行，导致列数据错位（某列无数据时后续文件数据从错误行开始），改为统一计算目标表的整体最后数据行，所有列从同一行开始粘贴
• 添加目标表FI列自动填充对应源文件名的逻辑
• 增加列标题匹配的容错判断，避免因源表无对应列导致的错误

修改后的完整VBA代码 #

Sub MergeExcelFiles()
    Dim wbTarget As Workbook
    Dim wbSource As Workbook
    Dim wsTarget As Worksheet
    Dim wsSource As Worksheet
    Dim FileFolder As String
    Dim FileName As String
    Dim dictHeaders As Object
    Dim headerRow As Long, sourceStartRow As Long
    Dim targetLastRow As Long, sourceLastRow As Long
    Dim targetLastCol As Long, sourceLastCol As Long
    Dim i As Long, sourceColIndex As Long
    Dim pasteRowStart As Long, pasteRowCount As Long
    
    ' 目标文件夹路径
    FileFolder = "C:\Users\kk\Desktop\Merged files\"
    ' 检查文件夹是否存在
    If Not FileFolderExists(FileFolder) Then
        MsgBox "指定文件夹不存在！", vbCritical, "错误"
        Exit Sub
    End If
    
    ' 绑定目标工作簿和工作表
    Set wbTarget = Workbooks("CD")
    Set wsTarget = wbTarget.Worksheets("Sheet1")
    headerRow = 1
    sourceStartRow = 2
    targetLastCol = wsTarget.Cells(headerRow, Columns.Count).End(xlToLeft).Column
    
    ' 遍历文件夹下的Excel文件
    FileName = Dir(FileFolder & "*.xls*")
    Do Until FileName = ""
        ' 打开源文件
        Set wbSource = Workbooks.Open(Filename:=FileFolder & FileName, UpdateLinks:=False)
        Set wsSource = wbSource.Worksheets("Steel")
        Set dictHeaders = CreateObject("Scripting.Dictionary")
        
        ' 加载源表表头到字典（键为大写表头，值为列索引）
        sourceLastCol = wsSource.Cells(headerRow, Columns.Count).End(xlToLeft).Column
        For i = 1 To sourceLastCol
            If Not dictHeaders.Exists(UCase(wsSource.Cells(headerRow, i).Value)) Then
                dictHeaders.Add UCase(wsSource.Cells(headerRow, i).Value), i
            End If
        Next i
        
        ' 计算目标表的最后数据行（统一所有列的粘贴起始点）
        targetLastRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row
        ' 如果目标表只有表头，粘贴起始行为2；否则为最后行+1
        pasteRowStart = IIf(targetLastRow = headerRow, headerRow + 1, targetLastRow + 1)
        
        ' 获取源表的数据行数（从第2行开始）
        sourceLastRow = wsSource.Cells(Rows.Count, 1).End(xlUp).Row
        pasteRowCount = sourceLastRow - sourceStartRow + 1
        ' 如果源表无数据，跳过当前文件
        If pasteRowCount <= 0 Then
            wbSource.Close SaveChanges:=False
            FileName = Dir()
            Continue Do
        End If
        
        ' 按目标表表头匹配源表数据并粘贴
        With wsTarget
            For i = 1 To targetLastCol
                ' 判断源表是否存在当前目标表头
                If dictHeaders.Exists(UCase(.Cells(headerRow, i).Value)) Then
                    sourceColIndex = dictHeaders(UCase(.Cells(headerRow, i).Value))
                    ' 粘贴整列数据
                    .Range(.Cells(pasteRowStart, i), .Cells(pasteRowStart + pasteRowCount - 1, i)).Value = _
                        wsSource.Range(wsSource.Cells(sourceStartRow, sourceColIndex), wsSource.Cells(sourceLastRow, sourceColIndex)).Value
                End If
            Next i
            
            ' 在FI列填充当前源文件名
            .Range(.Cells(pasteRowStart, "FI"), .Cells(pasteRowStart + pasteRowCount - 1, "FI")).Value = FileName
        End With
        
        ' 关闭源文件，不保存
        wbSource.Close SaveChanges:=False
        FileName = Dir()
    Loop
    
    ' 清理对象
    Set wsSource = Nothing
    Set wbSource = Nothing
    Set wsTarget = Nothing
    Set wbTarget = Nothing
    MsgBox "合并完成！", vbInformation, "提示"
End Sub

Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function

关键修改说明 #

1. 统一粘贴起始行：
   取消原代码按列单独计算粘贴起始行的逻辑，改为先计算目标表的整体最后数据行，所有列都从同一行开始粘贴，确保同一文件的所有列数据对齐

2. 添加文件名填充：
   在每次完成一个文件的数据粘贴后，直接给目标表FI列对应的数据行填充当前文件名，确保每行数据都关联正确的源文件

3. 容错处理：

   • 增加源表无数据时的跳过逻辑，避免无效粘贴
   • 增加表头匹配的存在性判断，避免因源表无对应列导致的运行时错误
   • 提前检查文件夹是否存在，增强代码健壮性

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