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

vista_info

中间人 发表于 2020-4-30 20:15
Sub 合()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String

我这里也改过类似的，运行宏，弹出对话框选定需要合并的文件，但是人懒没做重名sheet的区分，如果重名直接报错

[Visual Basic .NET] 纯文本查看 复制代码

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的功能，处于某种原因的考虑没有把两个功能的代码整合到一起

[Visual Basic .NET] 纯文本查看 复制代码

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

以上抛砖引玉

中间人

xbxbxbxb 发表于 2020-4-30 18:04
回复你一个类似的东东,需要VB下运行,功能没有你的强大,也能凑合用(好多年前抄别人的)

Sub 合()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
.Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("a65536").End(xlUp).Row + 1, 1)
Next
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("B1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub


合并当前目录下的所有xls

wuaipojie

支持楼主，谢谢分享

hhbluestar

收藏了。谢谢楼主@

lipinghao

这个工具完善了？会不会出现其它异常

ptmaliang

谢谢分享

xbxbxbxb

回复你一个类似的东东,需要VB下运行,功能没有你的强大,也能凑合用(好多年前抄别人的)

bdcpc

主要这个干什么用呢？

熊一只

谢谢分享

夏夜吉他

感谢分享！支持！