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

Question

我是为了个人日常工作而做的。 在谷歌搜索后，我找到了将多个工作簿（每个工作表有1个）合并到一个工作簿中的代码。 和那些工作表有一个相同的名称，它称为“shXetnaXe”，所以当我尝试选择工作簿时，它最终

"shXetnaXe" for sheet(1)

"shXetnaXe(1)" for sheet(2)

"shXetnaXe(2)" for sheet(3)

等等。

我希望这些工作表自动命名为原始选定工作簿的名称，这些原始名称是：“1月9日”“2月9日”，“9月3日”，我尝试稍微更改它，但它总是失败。

这是代码

`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

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

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

Answer 2

我在几个地方改变了你的代码。 您可以非常轻松地还原其中一些更改。

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