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

分享文件

工程造价基本知识

工程造价基础知识yasuo.pdf

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