如何在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

从这里使用我的代码：

多选文件并打开

编辑代码以适合您的要求。

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