求助编写VBA代码实现动态文件夹下指定工作表合并

Hey there! Let's tackle your VBA merge task step by step. I've adjusted the code to meet all your requirements, and added detailed comments so you can understand each part easily:

完整代码 #

Sub MergeReportSheets()
    Dim fd As FileDialog
    Dim targetFolder As String
    Dim fileName As String
    Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim targetWS As Worksheet
    Dim lastRowSource As Long
    Dim lastRowTarget As Long
    Dim dataRange As Range
    
    ' 关闭屏幕更新，提升运行速度
    Application.ScreenUpdating = False
    
    ' --- 1. 文件夹选择器功能 ---
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "请选择目标文件夹"
        .AllowMultiSelect = False
        If .Show <> -1 Then
            MsgBox "未选择文件夹，程序退出", vbInformation
            Application.ScreenUpdating = True
            Exit Sub
        End If
        targetFolder = .SelectedItems(1) & "\"
    End Set
    
    ' 指定合并后的目标工作表（这里假设你的宏工作簿中有名为"合并结果"的工作表，可根据实际修改）
    On Error Resume Next
    Set targetWS = ThisWorkbook.Worksheets("合并结果")
    On Error GoTo 0
    ' 如果目标工作表不存在，则新建一个
    If targetWS Is Nothing Then
        Set targetWS = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        targetWS.Name = "合并结果"
        ' 可选：如果需要复制源表表头，可取消下面注释（假设源表表头在A6）
        ' sourceWS.Range("A6").Copy targetWS.Range("A1")
    End If
    
    ' 遍历文件夹中的所有Excel文件
    fileName = Dir(targetFolder & "*.xlsx")
    Do While fileName <> ""
        ' 跳过当前宏工作簿，避免合并自身
        If targetFolder & fileName <> ThisWorkbook.FullName Then
            On Error Resume Next
            Set sourceWB = Workbooks.Open(targetFolder & fileName, ReadOnly:=True)
            On Error GoTo 0
            
            If Not sourceWB Is Nothing Then
                ' --- 2. 仅处理名为"report"的工作表 ---
                On Error Resume Next
                Set sourceWS = sourceWB.Worksheets("report")
                On Error GoTo 0
                
                If Not sourceWS Is Nothing Then
                    ' --- 3. 提取从A7开始的数据 ---
                    ' 找到A7开始的最后一行有效数据
                    lastRowSource = sourceWS.Cells(sourceWS.Rows.Count, "A").End(xlUp).Row
                    If lastRowSource >= 7 Then
                        ' 确定要复制的完整数据区域
                        Set dataRange = sourceWS.Range("A7:" & sourceWS.Cells(lastRowSource, sourceWS.UsedRange.Columns.Count).Address)
                        
                        ' 找到目标表的最后一行
                        lastRowTarget = targetWS.Cells(targetWS.Rows.Count, "A").End(xlUp).Row
                        If lastRowTarget = 1 And targetWS.Range("A1").Value = "" Then
                            ' 目标表为空时，从A1开始粘贴
                            dataRange.Copy
                            targetWS.Range("A1").PasteSpecial xlPasteValues
                        Else
                            ' 目标表已有数据，粘贴到下一行
                            dataRange.Copy
                            targetWS.Range("A" & lastRowTarget + 1).PasteSpecial xlPasteValues
                        End If
                        Application.CutCopyMode = False
                    End If
                End If
                
                ' 关闭源工作簿，不保存任何修改，保护原文件
                sourceWB.Close SaveChanges:=False
                Set sourceWB = Nothing
                Set sourceWS = Nothing
            End If
        End If
        fileName = Dir()
    Loop
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    MsgBox "合并完成！", vbInformation
End Sub

代码功能说明 #

• 动态文件夹选择：通过FileDialog弹窗让你手动选择目标文件夹，无需硬编码路径，灵活性拉满。如果未选文件夹，程序会友好提示并退出。
• 仅合并"report"工作表：遍历每个工作簿时，先检查是否存在名为report的工作表，只有存在时才处理，避免无意义的错误。
• 从A7开始提取数据：精准定位源表的A7单元格，获取从这里开始的所有有效数据区域，若A7以下没有数据则自动跳过该工作表。
• 避免公式错误：使用PasteSpecial xlPasteValues只粘贴单元格的值，完全剥离原工作表的公式，彻底杜绝跨工作簿引用导致的#REF!等错误。
• 保护源文件：以只读模式打开源工作簿，关闭时不保存任何修改，确保原文件不受影响。
• 自动创建汇总表：如果你的宏工作簿中没有指定的汇总工作表，程序会自动新建一个名为"合并结果"的工作表，你可以根据实际需求修改这个名称。

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