如何在 VBA 中合并多个选定的 Excel 文件？

Question

我是 VBA 新手，我想知道如何使用 VBA 合并多个选定的 Excel 文件。我尝试对选择文件的部分进行编码。我已经研究并尝试在互联网上复制代码并进行了一些编辑。我了解到您可以添加过滤器，所以我这样做了。但有时，即使我添加了正确的过滤器（基于我的研究），excel 文件也不会显示。我真的需要合并多个选定的 excel 文件。我希望你能帮助我。

顺便说一句，我正在使用用户表单。一个按钮，可以选择和合并选定的文件。如果可能的话，我希望用户看到所选文件的路径。我还不知道如何做到这一点，或者我应该使用什么工具，比如列表框或什么。提前致谢！

更新！

我有一个选择多个 Excel 文件的代码。我现在需要的是如何合并我选择的文件。

Dim FileNames As Variant
  Dim Msg As String
  Dim I As Integer
  FileNames = Application.GetOpenFilename(MultiSelect:=True)
  If IsArray(FileNames) Then
      Msg = "You selected:" & vbNewLine
      For I = LBound(FileNames) To UBound(FileNames)
          Msg = Msg & FileNames(I) & vbNewLine
      Next I
      MsgBox Msg
      tbPath.Value = Msg
  Else
      MsgBox "No files were selected."
  End If

Answer 1

这是我的代码...希望对您有所帮助。

    Sub mergeAllFiles()

    Dim This As Workbook 'Store the book with the macro
    Dim TmpB As Workbook 'store the book that has the sheets (one per book)
    Dim AllB As Workbook 'book to send all the books
    Dim sht As Worksheet 'the only sheet every book

    Dim FileNames As Variant
    Dim Msg As String
    Dim I As Integer

    Set This = ThisWorkbook
    FileNames = Application.GetOpenFilename(MultiSelect:=True)
    If IsArray(FileNames) Then
        Workbooks.Add 'add a new book to store all the sheets
        Set AllB = ActiveWorkbook
        AllB.SaveAs This.Path & "\allSheetsInOne" & SetTimeName & ".xlsx", 51
        'The function is to store a different name every time and avoid error
        Msg = "You selected:" & vbNewLine

        For I = LBound(FileNames) To UBound(FileNames)
            Workbooks.Open Filename:=FileNames(I)
            Set TmpB = ActiveWorkbook
            TmpB.Activate
            Set sht = ActiveSheet 'because you say that the book has only one sheet
            sht.Copy Before:=AllB.Sheets(Sheets.Count) 'send it to the end of the sheets
            TmpB.Close 'we don't need the book anymore
            Set TmpB = Nothing 'empty the var to use it again
            Set sht = Nothing
            Msg = Msg & FileNames(I) & vbNewLine
        Next I
        MsgBox Msg
        tbPath.Value = Msg
    Else
        MsgBox "No files were selected."
    End If
End Sub


Function SetTimeName()
Dim YY
Dim MM
Dim DD
Dim HH
Dim MI
Dim SS
Dim TT

YY = Year(Date)
MM = Month(Date)
DD = Day(Date)
HH = Hour(Now)
MI = Minute(Now)
SS = Second(Now)

TT = Format(YY, "0000") & Format(MM, "00") & Format(DD, "00") & Format(HH, "00") & Format(MI, "00") & Format(SS, "00")

SetTimeName = TT
End Function

告诉我是否需要改进。

Answer 2

从这里使用我的代码：

Multi-Select Files and open

编辑代码以满足您的要求。

Sub OPenMultipleWorkbooks()
'Open Multiple .xlsx files
    Application.DisplayAlerts = False
    Dim wb As Workbook, bk As Workbook
    Dim sh As Worksheet
    Dim GetFile As Variant, Ws As Worksheet

    Set wb = ThisWorkbook
    Set sh = wb.ActiveSheet

    For Each Sheet In Sheets
        If Sheet.Name <> sh.Name Then Sheet.Delete
    Next Sheet

    ChDrive "C:"
    Application.ScreenUpdating = False

    GetFile = Application.GetOpenFilename(FileFilter:="XLSX(*.xlsx), *.xlsx", Title:="Open XLSX- File", MultiSelect:=True)

    On Error Resume Next

    If GetFile <> False Then

        On Error GoTo 0

        For i = 1 To UBound(GetFile)

            Set bk = Workbooks.Open(GetFile(i))
            Sheets(1).Move Before:=wb.Sheets(1)
            bk.Close True
        Next i

    End If

End Sub