在將多個工作簿合並到一個工作簿之后，根據文件名重命名工作表

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