Sub 合并当前工作簿下的所有工作表() Application.ScreenUpdating = False For j = 1 To Sheets.Count If Sheets(j).Name <> ActiveSheet.Name Then X = Range("A1048576").End(xlUp).Row + 1 Sheets(j).UsedRange.Copy Cells(X, 1) End If Next Range("A1").Select Application.ScreenUpdating = True MsgBox "当前工作簿下的全部工作表已经合并完毕!", vbInformation, "提示" END SUB Dim FileOpen Dim X As Integer Application.ScreenUpdating = False FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="合并工作薄") X = 1 While X <= UBound(FileOpen) Workbooks.Open Filename:=FileOpen(X) Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) X = X + 1 Wend ExitHandler: Application.ScreenUpdating = True Exit Sub errhadler: MsgBox Err.Description End Sub