Question

如何使用VB实现多个excel表格合并在一个EXCEL表格里面

目前一个文件夹里面有多个EXCEL表格，现在要通过VB实现将文件夹的多个EXCEL表格合并到一个excel表格里面，且每个EXCEL文件分别在合并的EXCEL表格中占用一个sheet页面。

Answer 1

附件中有完整示例，运行 hb 后会弹出选择合并文件夹的对话框，选择后会将被选目录下所有工作薄的工作表合并到一个新建工作薄，为区分方便，原工作薄中的所有工作表合并后的sheet名称以同一颜色显示，并以“原工作薄-原工作表”的格式命名sheet，以下为完整代码

Private Sub hb()
    Dim hb As Object, kOne As Boolean, tabcolor As Long
    Set hb = Workbooks.Add
    Application.DisplayAlerts = False
    For i = hb.Sheets.Count To 2 Step -1
        hb.Sheets(i).Delete
    Next
    
    Dim FileName As String, FilePath As String
    Dim iFolder As Object, rwk As Object, Sh As Object
    Set iFolder = CreateObject("shell.application").BrowseForFolder(0, "请选择要合并的文件夹", 0, "")
    If iFolder Is Nothing Then Exit Sub
    FilePath = iFolder.Items.Item.Path
    FilePath = IIf(Right(FilePath, 1) = "\", FilePath, FilePath & "\")
    FileName = Dir(FilePath & "*.xls*")
    Do Until Len(FileName) = 0
        If UCase(FilePath & FileName) <> UCase(ThisWorkbook.Path & "\" & ThisWorkbook.Name) Then
            Set rwk = Workbooks.Open(FileName:=FilePath & FileName)
            tabcolor = Int(Rnd * 56) + 1
            With rwk
                For Each Sh In .Worksheets
                    Sh.Copy After:=hb.Sheets(hb.Sheets.Count)
                    hb.Sheets(hb.Sheets.Count).Name = FileName & "-" & Sh.Name
                    hb.Sheets(hb.Sheets.Count).Tab.ColorIndex = tabcolor
                    If Not kOne Then hb.Sheets(1).Delete: kOne = True
                Next
                .Close True
             End With
        End If
        Set rwk = Nothing
        FileName = Dir
    Loop
    Application.DisplayAlerts = True
End Sub

Answer 2

由于你描述得太简单了，所以，只能给你提供一个思路，请按照此思路，进行修改完善代码即可。

Sub FileJoin()
    Dim Wb As Workbook
    Dim cPath$, myFile$
    cPath = ThisWorkbook.Path & "\"'获取本文件所在路径
    '如果扩展名不是xls请修改为你实际的扩展名
    myFile = Dir(cPath & "*.xls")
    Set Wb = ThisWorkbook
    Application.ScreenUpdating = False
    Do While myFile <> ""
        If myFile <> ThisWorkbook.Name Then
            With Workbooks.Open(cPath & myFile)
                '将子文件中的第一个工作表复制到本工作薄中
                .Sheets(1).Copy after:=Wb.Sheets(Wb.Sheets.Count)
                .Close False
            End With
        End If
        myFile = Dir'在本文件夹下查找下一个xls扩展名的文件
    Loop
    Application.ScreenUpdating = True
    MsgBox "汇总完毕！", vbInformation, "提示"
End Sub