[随波逐流]Excel多簿多表合并工具 V1.0 20200501

中间人 发表于 2020-4-30 20:15

Sub 合()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
我这里也改过类似的，运行宏，弹出对话框选定需要合并的文件，但是人懒没做重名sheet的区分，如果重名直接报错

Sub CombineSheet()

    Dim FileOpen
    Dim i As Integer
    Application.ScreenUpdating = False
    FileOpen = Application.GetOpenFilename(FileFilter:="所有数据文件 (*.xls;*.xlsx;*.csv),*.xls;*.xlsx;*.csv,Excel 文件 (*.xls),*.xls,Excel2007 文件 (*.xlsx),*.xlsx,CSV 文件 (*.csv),*.csv", MultiSelect:=True, Title:="CombineSheet")
    i = 1
    
    While i <= UBound(FileOpen)
        Workbooks.Open Filename:=FileOpen(i)
        Lable = Split(ActiveWorkbook.Name, ".")
        Sheets(1).Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)  'Sheets(1)表明默认合并各个文件第一个sheets 如果需要合并全部要用 Sheets(1)
        Sheets(ThisWorkbook.Sheets.Count).Name = Lable(0)
        i = i + 1
    Wend
    
ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub
    
    
errhadler:
    MsgBox Err.Description

End Sub

可能需要配合清除空白sheet的功能，处于某种缘由的思考没有把两个功能的代码整合到一起

Sub DeleteEmptySheets()

    Dim FileOpen
    Dim i As Integer
    Dim WorkSheetsSelect As Worksheet
    
    
    Application.ScreenUpdating = False
    FileOpen = Application.GetOpenFilename(FileFilter:="所有数据文件 (*.xls;*.xlsx;*.csv),*.xls;*.xlsx;*.csv,Excel 文件 (*.xls),*.xls,Excel2007 文件 (*.xlsx),*.xlsx,CSV 文件 (*.csv),*.csv", MultiSelect:=True, Title:="CombineSheet")
    i = 1
    
    While i <= UBound(FileOpen)
       Workbooks.Open Filename:=FileOpen(i)
       'MsgBox "ActiveWorkbook运行结果（活动工作簿）：" & ActiveWorkbook.Name
       For Each WorkSheetsSelect In ActiveWorkbook.Worksheets
            If Application.WorksheetFunction.CountA(WorkSheetsSelect.Cells) = 0 Then
                Application.DisplayAlerts = False
                WorkSheetsSelect.Delete
                Application.DisplayAlerts = True
            End If
       Next
       ActiveWorkbook.Save
       ActiveWorkbook.Close
       i = i + 1
    Wend
    
    MsgBox "Empty Sheets Delete Finished!"

ExitHandler:
        Application.ScreenUpdating = True
        Exit Sub
        
errhadler:
        MsgBox Err.Description
    

End Sub

以上抛砖引玉