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

Question

I made this for my personal daily jobs. after I search on google, I found the code for merging the multiple workbooks (each has 1 worksheet) into one workbook. and those worksheet have a same name it call "shXetnaXe", so when i try to select the workbooks, it ended up

"shXetnaXe" for sheet(1)

"shXetnaXe(1)" for sheet(2)

"shXetnaXe(2)" for sheet(3)

And so on.

I want those sheets to automatically named as their original selected workbook's name those original names are: "1 sept" "2 sept" "3 sept" , I have try changing it a little bit, but it always fail.

Here's the code

`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

The problem is that openfiles.name returns the full file path and name of the file. You cannot name a worksheet with certain special characters, eg / , \\ or :.

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

I changed your code on several spots. You can revert some of these changes very easily.

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

I deleted this part

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

It deleted the first worksheet of the current file. I wasn't sure if this was intended. If so put this line back in (at the same position)

crntfile.Worksheets(1).Delete

HTH