求帮忙改个excel的宏代码，实现excel文件合并后sheet名称为原来excel的文件名

Question

本人需要合并几个excel文件到一个excel文件，网上找到如下宏代码（测试可行）

Sub CombineWorkbooks()
Dim FilesToOpen
Dim x As Integer

On Error GoTo ErrHandler
Application.ScreenUpdating = False

FilesToOpen = Application.GetOpenFilename _
(FileFilter:="MicroSoft Excel文件(*.xls),*.xls", _
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
这个宏的作用是合并所选的excel文件 并且sheet表名使用的还是原excel文件的sheet名称 请问如何使新生成的sheet表名换成原excel文件的文件名。

请帮忙的人测试过以后再将代码贴出来。
难道这个 功能没办法实现吗

Answer 1

右键左下角的工作表查看代码，复制以下代码：
Sub 多表多文件合并为多表一文件()

Dim FileArray

Dim X As Integer

Dim strFilePath As String
Dim strFileName As String
Dim intNum As Integer

Application.ScreenUpdating = False

FileArray = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="合并工作薄")

X = 1

While X <= UBound(FileArray)

Workbooks.Open Filename:=FileArray(X)

'MsgBox (FileArray(X)) 'ThisWorkbook.Sheets.

strFilePath = FileArray(X)
intNum = InStrRev(strFilePath, "\") '使用instrrev函数获取最后文件夹名截至的位置
strFileName = Mid(strFilePath, intNum + 1) '文件名

ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = strFileName

Sheets().Move after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

X = X + 1

Wend

ExitHandler:

Application.ScreenUpdating = True

Exit Sub

errhadler:

MsgBox Err.Description

End Sub

保存后，回到excel，选 视图 =》 宏=》 查看宏=》找到 多表多文件合并为多表一文件，执行这个宏

Answer 2

http://zhidao.baidu.com/question/199520077480209085.html?oldq=1&from=evaluateTo#reply-box-1823928843
代码直接可用追问

请帮忙测试下，刚测试了和我贴的代码没什么大的区别，没达到我的要求。

追答

测试毛线。

谁晓得你的文件是啥样子的？

本回答被网友采纳