How can I rename sheets when combining Workbooks? - excel

Question

I need to combine workbooks from a folder, and I found the below code which should do exactly what I need. The code is from here.
The issue I am encountering, that the worksheets in my workbooks all have the same long title, and it seems to crash the Sub as excel can't auto rename the sheets due to conflict (e.g. there is no room to append with (2) and (3) etc.).
How can I add onto the code to rename the sheets something arbitrary, e.g. Copied1, Copied 2, etc... ?
Sub MergeWorkbooks()
Dim FolderName As String
Dim directory As String, fileName As String
Dim wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet
Set wb1 = Workbooks.Add
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder."
.AllowMultiSelect = False
.Show
On Error Resume Next
FolderName = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
directory = FolderName & "\"
fileName = Dir(directory & "*.xls?")
Do While fileName <> ""
Set wb2 = Workbooks.Open(directory & fileName)
For Each ws In wb2.Sheets
ws.Copy after:=wb1.Sheets(Sheets.Count)
Next ws
wb2.Close savechanges:=False
fileName = Dir
Loop
End Sub

Answer 1

Use variable i to rename your sheets before moving them to your other book. The i corresponds to the book the sheet came from in your loop.
So the 5th book will have a sheet name of Sheet1 5 and the 6th book will be Sheet1 6 and so on for every sheet in every book.
Dim i As Long
i = 1
Do While Filename <> ""
Set wb2 = Workbooks.Open(directory & Filename)
For Each ws In wb2.Sheets
ws.Name = ws.Name & Chr(32) & i '<-- Rename
ws.Copy after:=wb1.Sheets(Sheets.Count)
Next ws
wb2.Close savechanges:=False
Filename = Dir
i = i + 1 '<-- Increment i for next bok
Loop
This will only work if the code is ran once - If you try to re-run the code on the same books with similar names, the index i will have already been used. If this is a problem, you can rename the sheets to corrospond with the number of sheets that are on the book (wb1.Sheets.Count)

Answer 2

Building off of urdearboy's response, I added user prompts to choose whether a batch rename is wanted, and if it is, to choose the batch name. It's nice to have the option when needed!
Sub MergeWorkbooks()
Dim FolderName As String
Dim directory As String, fileName As String
Dim wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim iAnswer As VbMsgBoxResult
Dim xAppend As String
Set wb1 = Workbooks.Add
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder."
.AllowMultiSelect = False
.Show
On Error Resume Next
FolderName = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
directory = FolderName & "\"
fileName = Dir(directory & "*.xls?")
'Prompt user to decide if batch rename is required
iAnswer = MsgBox("Would you like to batch rename the worksheets?", vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
'vbYes: Rename Worksheets
If iAnswer = vbYes Then
1:
xAppend = InputBox(Prompt:= _
"Enter new batch name for worksheets." _
& vbNewLine & vbNewLine & _
"Sheets will be appended with number based on the order in which they are copied." _
& vbNewLine & vbNewLine & _
"If 'Cancel' is selected, worksheets will be renamed as number only, based on order in which they are copied.", _
Title:="Naming Convention")
If InStr(xAppend, "<") > 0 _
Or InStr(xAppend, ">") > 0 _
Or InStr(xAppend, ":") > 0 _
Or InStr(xAppend, Chr(34)) > 0 _
Or InStr(xAppend, "/") > 0 _
Or InStr(xAppend, "\") > 0 _
Or InStr(xAppend, "|") > 0 _
Or InStr(xAppend, "?") > 0 _
Or InStr(xAppend, "*") > 0 _
Then
MsgBox "Suggested filename contains an invalid character"
GoTo 1
End If
Dim i As Long
i = 1
Do While fileName <> ""
Set wb2 = Workbooks.Open(directory & fileName)
For Each ws In wb2.Sheets
ws.Name = xAppend & i '<-- Rename
ws.Copy after:=wb1.Sheets(Sheets.Count)
Next ws
wb2.Close savechanges:=False
fileName = Dir
i = i + 1 '<-- Increment i for next bok
Loop
'vbNo: Rename Worksheets
ElseIf iAnswer = vbNo Then
Do While fileName <> ""
Set wb2 = Workbooks.Open(directory & fileName)
For Each ws In wb2.Sheets
ws.Copy after:=wb1.Sheets(Sheets.Count)
Next ws
wb2.Close savechanges:=False
fileName = Dir
Loop
'vb Canel: Exit
Else
Exit Sub
End If
End Sub