如何合并多份Excel文件的指定工作表？VBA代码GetDirectory行报错求助

问题说明 #

需要合并多个Excel文件到一个文件中，每个源文件包含多个工作表（数量、顺序一致），无法转CSV格式，需提取每个工作簿的第三个工作表。使用网上获取的VBA代码时，在path = GetDirectory("Select a folder containing Excel files you want to merge")行报错。

错误原因 #

GetDirectory并非VBA内置函数，代码未定义该函数导致运行错误；同时原代码默认提取第一个工作表，不符合提取第三个工作表的需求。

修正后的完整VBA代码 #

Sub MergeThirdSheets()
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Dim path As String, ThisWB As String
    Dim shtDest As Worksheet, Wkb As Workbook
    Dim CopyRng As Range, Dest As Range
    Dim RowofCopySheet As Integer
    Dim fd As FileDialog

    RowofCopySheet = 2 ' 从源工作表的第2行开始复制（跳过表头）
    ThisWB = ActiveWorkbook.Name

    ' 使用内置文件夹选择对话框替代未定义的GetDirectory
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "选择包含要合并的Excel文件的文件夹"
        If .Show = -1 Then
            path = .SelectedItems(1)
        Else
            ' 用户取消选择，终止宏
            Application.EnableEvents = True
            Application.ScreenUpdating = True
            MsgBox "未选择文件夹，宏已终止"
            Exit Sub
        End If
    End Set

    ' 设置目标工作表为当前工作簿的第一个工作表
    Set shtDest = ActiveWorkbook.Sheets(1)
    ' 遍历文件夹中的xlsm文件（如需支持xlsx，可改为"*.xls*"）
    Filename = Dir(path & "\*.xlsm", vbNormal)
    
    If Len(Filename) = 0 Then
        MsgBox "文件夹中未找到xlsm文件"
        GoTo Cleanup
    End If

    Do Until Filename = vbNullString
        If Not Filename = ThisWB Then
            Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
            ' 提取第三个工作表，修正Cells引用需绑定指定工作表
            With Wkb.Sheets(3)
                Set CopyRng = .Range(.Cells(RowofCopySheet, 1), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count))
            End With
            ' 设置目标区域：目标工作表最后一行的下一行（避免空白行干扰）
            Set Dest = shtDest.Range("A" & shtDest.Cells(shtDest.Rows.Count, "A").End(xlUp).Row + 1)
            ' 复制数据（如需仅复制值，可改为CopyRng.Copy: Dest.PasteSpecial xlPasteValues）
            CopyRng.Copy Dest
            Wkb.Close SaveChanges:=False
        End If
        Filename = Dir()
    Loop

Cleanup:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox "合并完成"
End Sub

关键修改点 #

• 用VBA内置的FileDialog文件夹选择器替换未定义的GetDirectory，解决函数不存在的错误
• 将原代码的Wkb.Sheets(1)改为Wkb.Sheets(3)，实现提取第三个工作表的需求
• 通过With语句绑定工作表对象，修正Cells跨工作表引用的潜在错误
• 增加用户取消选择、无目标文件的异常处理逻辑
• 改用End(xlUp)获取目标工作表最后一行，比SpecialCells(xlCellTypeLastCell)更可靠（避免空白行干扰）

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