在将多个工作簿合并到一个工作簿后，根据文件名重命名工作表

我为了我个人的日常工作做了这个。 我search谷歌后，我发现合并多个工作簿（每个有1个工作表）到一个工作簿的代码。 和那些工作表具有相同的名称叫做“shXetnaXe”，所以当我尝试select工作簿时，它结束了

"shXetnaXe" for sheet(1)

"shXetnaXe(1)" for sheet(2)

"shXetnaXe(2)" for sheet(3)

等等。

我想这些工作表自动命名为他们的原始选定工作簿的名称是：“1 sept”“2 sept”“3 sept”，我试着改变它一点，但总是失败。

这是代码

 `Sub opensheets() Dim openfiles Dim crntfile As Workbook Set crntfile = Application.ActiveWorkbook Dim x As Integer On Error GoTo ErrHandler Application.ScreenUpdating = False openfiles = Application.GetOpenFilename _ (FileFilter:="Microsoft Excel Files (*.xls;*.xlsx),*.xls;*.xlsx", _ MultiSelect:=True, Title:="Select Excel file to merge!") If TypeName(openfiles) = "Boolean" Then MsgBox "You need to select atleast one file" GoTo ExitHandler End If x = 1 While x <= UBound(openfiles) Workbooks.Open Filename:=openfiles(x) Sheets().Move After:=crntfile.Sheets(crntfile.Sheets.Count) Set rnmsht = Workbook.Open Sheets(openfiles) = rnmsht Before:=ActiveWorkbook.Sheets(openfiles.name) x = x + 1 Wend Application.DisplayAlerts = False Sheets(1).Select ActiveWindow.SelectedSheets.Delete ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub' 

Answer 1

我在几个地方改变了你的代码。 你可以很容易地恢复一些这些变化。

 Sub opensheets() Dim openfiles Dim crntfile As Workbook Set crntfile = Application.ActiveWorkbook Dim targetWkbk As Workbook Dim newName As String Dim x As Integer On Error GoTo ErrHandler Application.ScreenUpdating = False openfiles = Application.GetOpenFilename _ (FileFilter:="Microsoft Excel Files (*.xls;*.xlsx),*.xls;*.xlsx", _ MultiSelect:=True, Title:="Select Excel file to merge!") If TypeName(openfiles) = "Boolean" Then MsgBox "You need to select atleast one file" GoTo ExitHandler End If With crntfile x = 1 While x <= UBound(openfiles) Set targetWkbk = Workbooks.Open(Filename:=openfiles(x)) newName = targetWkbk.Name 'you need this part if there are several (more than 1) worksheets 'in your workbook, this might come in handy for later purposes 'however, if it is always just one worksheet, delete the following parts 'Line: For i = 1.. 'Line: Next 'part & " Sheet " & i For i = 1 To targetWkbk.Sheets.Count targetWkbk.Worksheets(i).Copy After:=.Sheets(.Sheets.Count) .Worksheets(.Sheets.Count).Name = newName & " Sheet " & i Next targetWkbk.Close x = x + 1 Wend End With ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub 

我删除了这部分

 Application.DisplayAlerts = False Sheets(1).Select ActiveWindow.SelectedSheets.Delete 

它删除了当前文件的第一个工作表。 我不确定这是否是有意的。 如果是的话，把这条线放回（在相同的位置）

 crntfile.Worksheets(1).Delete 

HTH

Answer 2

问题是，openfiles.name返回完整的文件path和文件的名称。 您不能用某些特殊字符命名工作表，例如/，\或：。

 Sub opensheets() Dim openfiles Dim xlWB As Workbook Dim NewSheetName as String Dim x As Integer On Error GoTo ErrHandler Application.ScreenUpdating = False openfiles = Application.GetOpenFilename _ (FileFilter:="Microsoft Excel Files (*.xls;*.xlsx),*.xls;*.xlsx", _ MultiSelect:=True, Title:="Select Excel file to merge!") If TypeName(openfiles) = "Boolean" Then MsgBox "You need to select atleast one file" GoTo ExitHandler End If x = 1 While x <= UBound(openfiles) Set xlWB = Workbooks.Open(Filename:=openfiles(x)) NewSheetName = xlWB.Name xlWB.Sheets(1).Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = NewSheetName x = x + 1 Wend ' Application.DisplayAlerts = False ' Sheets(1).Select ' ActiveWindow.SelectedSheets.Delete ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub