合并功能宏

Sub 合并所有Excel工作表()

'禁用屏幕刷新/警告提示，提升速度
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim 主目录 As String
Dim 汇总工作簿 As Workbook
Dim 文件名前缀 As String

'==================== 核心配置 ====================
'1. 获取当前宏文件所在的主目录
主目录 = ThisWorkbook.Path & "\"
If 主目录 = "\" Then
    MsgBox "请先保存当前Excel文件，再运行宏！", vbCritical
    Exit Sub
End If

'2. 生成汇总文件名：Allsheet + 年月日时分
文件名前缀 = "Allsheet" & Format(Now(), "YYYYMMDDHHMM")

'3. 创建新的汇总工作簿
Set 汇总工作簿 = Workbooks.Add(xlWBATWorksheet)
汇总工作簿.Sheets(1).Name = "默认工作表"

'4. 遍历目录下所有Excel文件（含子目录）—— 使用FileSystemObject 稳定无BUG
Call 遍历目录稳定版(主目录, 汇总工作簿)

'==================== 收尾处理 ====================
'删除默认空白工作表
On Error Resume Next
汇总工作簿.Sheets("默认工作表").Delete
On Error GoTo 0

'保存汇总文件
汇总工作簿.SaveAs 主目录 & 文件名前缀 & ".xlsx", FileFormat:=xlOpenXMLWorkbook
汇总工作簿.Close SaveChanges:=False

'恢复Excel设置
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "合并完成！" & vbCrLf & "文件路径：" & 主目录 & 文件名前缀 & ".xlsx", vbInformation

End Sub

'==================== 稳定版遍历（使用FSO，绝对不会报错） ====================
Private Sub 遍历目录稳定版(当前目录 As String, 汇总工作簿 As Workbook)

Dim fso As Object
Dim 文件夹 As Object
Dim 子文件夹 As Object
Dim 文件 As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set 文件夹 = fso.GetFolder(当前目录)

'遍历当前文件夹里的所有 Excel 文件
For Each 文件 In 文件夹.Files
    If LCase(fso.GetExtensionName(文件.Path)) Like "xls*" Then
        '跳过自身
        If 文件.Name <> ThisWorkbook.Name Then
            On Error Resume Next
            Dim 当前文件 As Workbook
            Set 当前文件 = Workbooks.Open(文件.Path, ReadOnly:=True, AddToMru:=False)
            On Error GoTo 0
            
            If Not 当前文件 Is Nothing Then
                Dim 工作表 As Worksheet
                For Each 工作表 In 当前文件.Worksheets
                    Dim 新名称 As String
                    Dim 计数 As Integer
                    计数 = 0
                    新名称 = 工作表.Name
                    
                    '处理重名
                    Do While 工作表存在(新名称, 汇总工作簿)
                        计数 = 计数 + 1
                        新名称 = 工作表.Name & "重名" & 计数
                    Loop
                    
                    '复制工作表
                    工作表.Copy After:=汇总工作簿.Sheets(汇总工作簿.Sheets.Count)
                    汇总工作簿.Sheets(汇总工作簿.Sheets.Count).Name = 新名称
                Next 工作表
                
                当前文件.Close SaveChanges:=False
                Set 当前文件 = Nothing
            End If
        End If
    End If
Next

'递归所有子文件夹（不会冲突！）
For Each 子文件夹 In 文件夹.SubFolders
    遍历目录稳定版 子文件夹.Path & "\", 汇总工作簿
Next

Set fso = Nothing
Set 文件夹 = Nothing

End Sub

'==================== 辅助函数：判断工作表是否存在 ====================
Private Function 工作表存在(名称 As String, 工作簿 As Workbook) As Boolean

Dim 表 As Worksheet
On Error Resume Next
Set 表 = 工作簿.Sheets(名称)
On Error GoTo 0
工作表存在 = Not 表 Is Nothing

End Function
合并功能宏.zip