【求助】合并多个excel的宏

[qq_19763005]

求助大神，下面是个合并多个excel文件至一个excel形成多个sheet页的宏，但是每个sheet页的命名是乱的，也看不出什么规律，大神可以帮助我修改成，每个excel的名字对应到每个sheet的命名上么？万分感谢啦

Sub CombineWorkbooks()
Dim FilesToOpen
Dim x As Integer
On Error GoTo ErrHandler
Application.ScreenUpdating = False
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="MicroSoft Excel文件(*.xlsx),*.xlsx", _
MultiSelect:=True, Title:="要合并的文件")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "没有选中文件"
GoTo ExitHandler
End If
x = 1
While x <= UBound(FilesToOpen)
Workbooks.Open Filename:=FilesToOpen(x)
Sheets().Move after:=ThisWorkbook.Sheets _
(ThisWorkbook.Sheets.Count)
x = x + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub

[yangmingjingren]

Sub CombineWorkbooks() Dim FilesToOpen Dim x As Integer On Error GoTo ErrHandler Application.ScreenUpdating = False FilesToOpen = Application.GetOpenFilename _ (FileFilter:="MicroSoft Excel文件(*.xlsx),*.xlsx", _ MultiSelect:=True, Title:="要合并的文件") If TypeName(FilesToOpen) = "Boolean" Then MsgBox "没有选中文件" GoTo ExitHandler End If x = 1 With ActiveWorkbook While x <= UBound(FilesToOpen) Set openfile = Workbooks.Open(FilesToOpen(x)) Sheets(1).Copy after:=.Sheets(.Sheets.count) .Sheets(.Sheets.count).Name = Sheets(1).Name x = x + 1 openfile.Close Wend End With ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub 只复制一页，多页自己加循环吧~