VBA批量合并Excel数据：文件名与工作表名全量填充求助

我编写了一段VBA代码，用于遍历指定文件夹中的多个Excel文件，将每个文件内的Monthly1、Monthly2、Monthly3、Monthly4四个工作表的指定区域数据（仅复制值，忽略格式与公式）合并到目标工作表ConsolidatedData中。目前文件名与工作表名已出现在输出结果中，但无法确保所有对应数据行都填充该信息，恳请提供帮助。

原代码 #

Sub ConsolidateData()
    Dim SourceFolder As String
    Dim FileExt As String
    Dim FileName As String
    Dim wbSource As Workbook
    Dim wsSource1 As Worksheet, wsSource2 As Worksheet, wsSource3 As Worksheet, wsSource4 As Worksheet
    Dim wsDest As Worksheet
    Dim DestRow As Long

    ' Set the source folder path and file extension
    SourceFolder = "C:\TEST_1\"
    FileExt = "*.xlsx" ' Change to your file extension

    ' Set the destination worksheet
    Set wsDest = ThisWorkbook.Sheets("ConsolidatedData") ' Change to your destination sheet name

    ' Clear existing data in the destination sheet
    wsDest.Cells.Clear

    ' Initialize destination row
    DestRow = 2

    ' Loop through each file in the folder
    FileName = Dir(SourceFolder & FileExt)
    Do While FileName <> ""
        Set wbSource = Workbooks.Open(SourceFolder & FileName, ReadOnly:=True)

        ' Set references to source worksheets
        Set wsSource1 = wbSource.Sheets("Monthly1") ' Change to your sheet names
        Set wsSource2 = wbSource.Sheets("Monthly2")
        Set wsSource3 = wbSource.Sheets("Monthly3")
        Set wsSource4 = wbSource.Sheets("Monthly4")

        ' Copy data from source sheets to destination sheet
        Dim LastRowSrc1 As Long
        Dim LastRowSrc2 As Long
        Dim LastRowSrc3 As Long
        Dim LastRowSrc4 As Long
        
        LastRowSrc1 = wsSource1.Cells(wsSource1.Rows.Count, "B").End(xlUp).Row
        LastRowSrc2 = wsSource2.Cells(wsSource2.Rows.Count, "B").End(xlUp).Row
        LastRowSrc3 = wsSource3.Cells(wsSource3.Rows.Count, "B").End(xlUp).Row
        LastRowSrc4 = wsSource4.Cells(wsSource4.Rows.Count, "B").End(xlUp).Row
        
        wsSource1.Range("B4:O30").Copy
        wsDest.Range("C" & DestRow).PasteSpecial xlPasteValues
        wsDest.Range("A" & DestRow, "A" & DestRow + LastRowSrc1 - 4).Value = FileName
        wsDest.Range("B" & DestRow, "B" & DestRow + LastRowSrc1 - 4).Value = wsSource1.Name
        DestRow = DestRow + LastRowSrc1 - 3

        wsSource2.Range("B4:O30").Copy
        wsDest.Range("C" & DestRow).PasteSpecial xlPasteValues
        wsDest.Range("A" & DestRow, "A" & DestRow + LastRowSrc2 - 4).Value = FileName
        wsDest.Range("B" & DestRow, "B" & DestRow + LastRowSrc2 - 4).Value = wsSource2.Name
        DestRow = DestRow + LastRowSrc2 - 3

        wsSource3.Range("B4:O29").Copy
        wsDest.Range("C" & DestRow).PasteSpecial xlPasteValues
        wsDest.Range("A" & DestRow, "A" & DestRow + LastRowSrc3 - 4).Value = FileName
        wsDest.Range("B" & DestRow, "B" & DestRow + LastRowSrc3 - 4).Value = wsSource3.Name
        DestRow = DestRow + LastRowSrc3 - 3

        wsSource4.Range("B4:O25").Copy
        wsDest.Range("C" & DestRow).PasteSpecial xlPasteValues
        wsDest.Range("A" & DestRow, "A" & DestRow + LastRowSrc4 - 4).Value = FileName
        wsDest.Range("B" & DestRow, "B" & DestRow + LastRowSrc4 - 4).Value = wsSource4.Name
        DestRow = DestRow + LastRowSrc4 - 3
        
        Application.CutCopyMode = False

        wbSource.Close SaveChanges:=False
        FileName = Dir
    Loop
End Sub

解决方案 #

问题核心在于原代码复制固定区域（如B4:O30），但填充文件名/工作表名时使用实际数据行数，两者行数不匹配导致部分行未被正确填充。修改后的代码会动态匹配实际数据区域，确保每一行数据都对应正确的文件名和工作表名：

Sub ConsolidateData()
    Dim SourceFolder As String
    Dim FileExt As String
    Dim FileName As String
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim DestRow As Long
    Dim LastRowSrc As Long
    Dim DataRows As Long
    
    ' 设置源文件夹路径和文件扩展名
    SourceFolder = "C:\TEST_1\"
    FileExt = "*.xlsx"
    
    ' 设置目标工作表
    Set wsDest = ThisWorkbook.Sheets("ConsolidatedData")
    
    ' 清空目标表现有数据
    wsDest.Cells.Clear
    ' 写入表头（按需启用，假设源表第3行是表头）
    ' wsDest.Range("A1:B1").Value = Array("文件名", "工作表名")
    ' wsDest.Range("C1:O1").Value = wbSource.Sheets("Monthly1").Range("B3:O3").Value
    
    ' 初始化目标行
    DestRow = 2
    
    ' 遍历文件夹中的文件
    FileName = Dir(SourceFolder & FileExt)
    Do While FileName <> ""
        Set wbSource = Workbooks.Open(SourceFolder & FileName, ReadOnly:=True)
        
        ' 遍历四个目标工作表，简化重复代码
        For Each wsSource In wbSource.Sheets(Array("Monthly1", "Monthly2", "Monthly3", "Monthly4"))
            ' 获取B列实际最后一行数据行
            LastRowSrc = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row
            
            ' 仅当存在有效数据时处理（第4行及以下有数据）
            If LastRowSrc >= 4 Then
                DataRows = LastRowSrc - 3 ' 计算要复制的数据行数（从第4行到LastRowSrc）
                
                ' 复制源表数据（仅值）
                wsSource.Range("B4:O" & LastRowSrc).Copy
                wsDest.Range("C" & DestRow).PasteSpecial xlPasteValues
                
                ' 填充文件名到A列对应行
                wsDest.Range("A" & DestRow & ":A" & DestRow + DataRows - 1).Value = FileName
                ' 填充工作表名到B列对应行
                wsDest.Range("B" & DestRow & ":B" & DestRow + DataRows - 1).Value = wsSource.Name
                
                ' 更新目标行指针
                DestRow = DestRow + DataRows
            End If
        Next wsSource
        
        Application.CutCopyMode = False
        wbSource.Close SaveChanges:=False
        FileName = Dir
    Loop
End Sub

修改说明 #

• 简化重复逻辑：用循环遍历四个工作表，避免重复编写四次相同代码
• 动态数据区域：根据B列实际最后一行确定复制范围，避免复制空行
• 行数严格匹配：计算实际数据行数DataRows，确保文件名/工作表名的填充范围与数据行数完全一致
• 有效性判断：仅当源表第4行及以下有数据时才处理，避免无效操作
• 可选表头处理：预留表头写入代码，按需启用可让合并后的数据结构更清晰

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