Sub MergeAllExcelSheets()

'Disable screen update / alerts to speed up
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim mainPath As String
Dim summaryWB As Workbook
Dim filePrefix As String

'==================== Core Settings ====================
'1. Get current macro file path
mainPath = ThisWorkbook.Path & "\"
If mainPath = "\" Then
    MsgBox "Please save this Excel file first before running the macro!" & vbCrLf & "请先保存当前Excel文件，再运行宏！", vbCritical
    Exit Sub
End If

'2. Generate output filename
filePrefix = "Allsheet" & Format(Now(), "YYYYMMDDHHMM")

'3. Create new summary workbook
Set summaryWB = Workbooks.Add(xlWBATWorksheet)
summaryWB.Sheets(1).Name = "DefaultSheet"

'4. Scan all Excel files in folder (including subfolders)
Call ScanFolderStable(mainPath, summaryWB)

'==================== Clean Up ====================
'Delete default blank sheet
On Error Resume Next
summaryWB.Sheets("DefaultSheet").Delete
On Error GoTo 0

'Save merged file
summaryWB.SaveAs mainPath & filePrefix & ".xlsx", FileFormat:=xlOpenXMLWorkbook
summaryWB.Close SaveChanges:=False

'Restore Excel settings
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "Merge completed!" & vbCrLf & "合并完成！" & vbCrLf & vbCrLf & "Path: " & mainPath & filePrefix & ".xlsx", vbInformation

End Sub

'==================== Stable Folder Scan (FSO) ====================
Private Sub ScanFolderStable(currentPath As String, summaryWB As Workbook)

Dim fso As Object
Dim folder As Object
Dim subFolder As Object
Dim file As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(currentPath)

'Loop all Excel files in current folder
For Each file In folder.Files
    If LCase(fso.GetExtensionName(file.Path)) Like "xls*" Then
        'Skip itself
        If file.Name <> ThisWorkbook.Name Then
            On Error Resume Next
            Dim currentWB As Workbook
            Set currentWB = Workbooks.Open(file.Path, ReadOnly:=True, AddToMru:=False)
            On Error GoTo 0
            
            If Not currentWB Is Nothing Then
                Dim ws As Worksheet
                For Each ws In currentWB.Worksheets
                    Dim newName As String
                    Dim count As Integer
                    count = 0
                    newName = ws.Name
                    
                    'Handle duplicate names
                    Do While SheetExists(newName, summaryWB)
                        count = count + 1
                        newName = ws.Name & "Dup" & count
                    Loop
                    
                    'Copy worksheet
                    ws.Copy After:=summaryWB.Sheets(summaryWB.Sheets.count)
                    summaryWB.Sheets(summaryWB.Sheets.count).Name = newName
                Next ws
                
                currentWB.Close SaveChanges:=False
                Set currentWB = Nothing
            End If
        End If
    End If
Next

'Recursive subfolders
For Each subFolder In folder.SubFolders
    ScanFolderStable subFolder.Path & "\", summaryWB
Next

Set fso = Nothing
Set folder = Nothing

End Sub

'==================== Helper: Check if sheet exists ====================
Private Function SheetExists(sheetName As String, wb As Workbook) As Boolean

Dim testSheet As Worksheet
On Error Resume Next
Set testSheet = wb.Sheets(sheetName)
On Error GoTo 0
SheetExists = Not testSheet Is Nothing

End Function

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

分享文件

工程造价基本知识

工程造价基础知识yasuo.pdf

DeepSeek-R1使用指南（简版）.pdf