Sub MergeWorkbooks() Dim sourceFolder As String Dim destWorkbook As Workbook Dim sourceWorkbook As Workbook Dim ws As Worksheet Dim lastRow As Long Dim totalRows As Long Dim fileNames As Variant Dim i As Integer
' 关闭屏幕刷新和自动计算 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual
' 创建新工作簿 Set destWorkbook = Workbooks.Add Set ws = destWorkbook.Sheets(1) ws.Name = "合并数据"
' 初始化标题标记 Dim headerCopied As Boolean headerCopied = False
' 选择源文件夹 With Application.FileDialog(msoFileDialogFolderPicker) .Title = "请选择包含工作簿的文件夹" If .Show = -1 Then sourceFolder = .SelectedItems(1) & "\" Else MsgBox "未选择文件夹，操作已取消。", vbInformation Exit Sub End If End With
' 获取所有Excel文件 fileNames = Dir(sourceFolder & "*.xls*")
' 遍历文件 Do While fileNames <> "" If fileNames <> ThisWorkbook.Name Then ' 排除当前工作簿 Set sourceWorkbook = Workbooks.Open(sourceFolder & fileNames)
With sourceWorkbook.Sheets(1) lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row If Not headerCopied Then ' 复制标题 .Rows(1).Copy ws.Rows(1) headerCopied = True totalRows = 1 End If
' 复制数据（跳过标题） If lastRow > 1 Then .Range("A2:F" & lastRow).Copy ws.Cells(totalRows + 1, 1).PasteSpecial xlPasteValues totalRows = totalRows + lastRow - 1 End If End With
sourceWorkbook.Close SaveChanges:=False End If fileNames = Dir Loop
' 自动调整列宽 ws.Columns.AutoFit
' 保存合并后的工作簿 With Application.FileDialog(msoFileDialogSaveAs) .Title = "保存合并后的工作簿" .InitialFileName = sourceFolder & "合并结果.xlsx" .FilterIndex = 1 If .Show Then destWorkbook.SaveAs .SelectedItems(1) MsgBox "数据合并完成，已保存至：" & .SelectedItems(1), vbInformation End If End With
' 恢复设置 Application.CutCopyMode = False Application.ScreenUpdating
