Add Sheet Name to Merge Files Macro

[ShanaVT]

Hello! I am using the below macro that I found to combine several worksheets into one workbooks on separate tabs. However, I need the Sheet names to be the names of the files so I know which is which - ideally the name of the file without ".xls" but if it has to be there that is fine. I was also wondering if there is a way to add to this macro that I can pull in csv files as well as excel or instead of. Thank you!

Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook

fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)

If (vbBoolean <> VarType(fnameList)) Then

If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wbkCurBook = ActiveWorkbook

For Each fnameCurFile In fnameList
countFiles = countFiles + 1

Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)

For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Next

wbkSrcBook.Close SaveChanges:=False

Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If

Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub

 

[Coding4Fun]

Untested just a guess as I am not sure exactly what you have stored in fnameCurFile

Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook


fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.csv;*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)


If (vbBoolean <> VarType(fnameList)) Then


If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Set wbkCurBook = ActiveWorkbook


For Each fnameCurFile In fnameList
countFiles = countFiles + 1


Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)


For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
ActiveSheet.Name = Replace(" & fnameCurFile & ", ".xlsx", "")
Next


wbkSrcBook.Close SaveChanges:=False


Next


Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If


Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub

 

[ShanaVT]

Thank you but this didn't work. The tab names actually already have the file name data in them so I am really looking to add something to the macro to shorten the sheet names after they are pulled in. Below is an example of the Sheet names and what I want them to look like.

20180926_DC_XXXXXXXX_Fund_12345 - current Sheet Names
20180926 - what i want the sheet names to be

If that doesn't make sense let me know.

Thanks for your help!

 

[Coding4Fun]

For clarity:
You want to ADD the COPYFROM filename to the COPYFROM sheet and then COPY the sheet to a central workbook?
So Book1 is the starting point, you then select 5 files to open and merge into Book1. You want to take the file name of Book2 and add it to the name of Book2:Sheet1 and then copy this sheet over to Book1.
The end result being in Book1 you would have say 5 sheets for example which each sheet name would be Book1 Sheet1, Book2 Sheet1, Book3 Sheet1, Book4 Sheet1, Book5 Sheet1

Also clarity on terminology

20180926_DCXXXXXXXX_Fund_12345 - Is this a Sheet Name or the Workbook Name (File name)?

 

[ShanaVT]

Hello! Sorry for the confusion. Let me see if I can explain it better. I start with Book 1 that has Sheet 1 only then I run the above macro I shared and it pulls in multiple additional Sheets from multiple files. So now I have Book 1 (named Sheet 1) and multiple other tabs all with a variation of this name - 20180926_DCXXXXXXXX_Fund_12345. All I want to do is write a macro to trim all the Sheet names for every Sheet (except Sheet 1) from 20180926_DCXXXXXXXX_Fund_12345 to the first 8 digits so that all the Sheet names look like this - 20180926.

Hopefully that makes more sense.

 

[Coding4Fun]

Maybe

Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook


fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.csv;*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)


If (vbBoolean <> VarType(fnameList)) Then


If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Set wbkCurBook = ActiveWorkbook


For Each fnameCurFile In fnameList
countFiles = countFiles + 1


Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)


For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
On Error GoTo NameTaken
wbkCurBook.Sheets(wbkCurBook.Sheets.Count).Name = Left(wbkSrcBook.Name, 8)
Next


wbkSrcBook.Close SaveChanges:=False


Next


Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If


Else
MsgBox "No files selected", Title:="Merge Excel files"
End If


Exit Sub
NameTaken:
If Err.Description = "That name is already taken. Try a different one." Then
wbkCurBook.Sheets(wbkCurBook.Sheets.Count).Name = Left(wbkSrcBook.Name, 8)
Resume Next
End If


End Sub