VBA to copy multiple worksheets and either rename sheet with file name or add column with filename

[PippaThePointer]

Hi,
I need to consolidate a number of worksheets from multiple workbooks into my template. I have found and tested lots of VBA code that almost does what i want. So far I am doing it it 2 steps.

1. copy all the selected files tabs into my template so it has lots of copied worksheets but add a row with file name or rename copied tab
2. consolildate all the worksheets into a new worksheet and remove all rows with blank 'qty'

The code that seems to give me the best results for step one is below but It works great if the source file only has one worksheet, but it fails if it has more than one worksheet. It cant seem to resolve the range when more than one sheet. It will work with multiple worksheets if i disble the function to add the worksheet name into new column. Other options i have tried is to copy the sheets but rename each worksheet to include the file name. Then my next macro could use that when consolidating into one sheet. However i have not succeded in this either.

If anyone could help me edit this code so it loops correctly it would be wonderful.

Sub MergeExcelFilesWithFileName()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
Dim c As Long, r As Long
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
c = ActiveSheet.UsedRange.Columns.Count
r = ActiveSheet.UsedRange.Rows.Count
'change Split value to get part of file name - 1 is second part
'This fails if more than one sheet in the source file.
wksCurSheet.Range(Cells(1, c + 1), Cells(r, c + 1)).Value = Split(wbkSrcBook.Name, " ")(1)
'add header - This works
wksCurSheet.Cells(1, c + 1).Value = "Store"
'Copy worksheet
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

 

[I_know_nuffin]

added a array variable to hold the workbook name
newtxt()

newtxt(1) should hold the name from the split

Sub MergeExcelFilesWithFileName()
Dim fnameList As Variant, fnameCurFile As Variant
Dim countFiles As Integer, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook As Workbook, wbkSrcBook As Workbook
Dim c As Long, r As Long, newtxt() As String

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

'open new book
Set wbkSrcBook = Workbooks.Open(filename:=fnameCurFile)
'for each sheet in new book
For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
'Debug.Print wksCurSheet.name
wksCurSheet.Activate
c = ActiveSheet.UsedRange.Columns.Count
r = ActiveSheet.UsedRange.Rows.Count
'change Split value to get part of file name - 1 is second part
'This fails if more than one sheet in the source file.
newtxt = Split(wbkSrcBook.name, " ") '(1)
wksCurSheet.Range(Cells(1, c + 1), Cells(r, c + 1)).Value = newtxt(0) 'Split(wbkSrcBook.name, " ")(1)
'add header - This works
wksCurSheet.Cells(1, c + 1).Value = "Store"
'Copy worksheet
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

 

[PippaThePointer]

Thank you! This workes perfectly. I can then run my second macro when required to consolidate all to one sheet, remove blank lines and qty=blank and then exports csv to another system.

 

[I_know_nuffin]

Glad you got it to work

 

[PippaThePointer]

Glad you got it to work

hi,
A quick followup (hopefully).

1. If the source data comes in and I want to use the last seperator of the file name, it then includes the file extention in the newtxt. ei. if source file is 'test storeA.xls' then the input for newtxt will be 'storeA.xls' instead o just 'storeA'. Can you suggest an edit for this.
2. Also my new data now has a particular sheet name that i want to ignore in the copy sheets. The example i have has 'Allocation' and 'Store Brand' and i dont want to copy 'Allocation' in my Macro.

 

[I_know_nuffin]

Hi

for the file name you could use

left(newtxt(1), instr(newtxt(1),".") -1)

Left (string,12)- returns the left hand characters of string - from 1 to12

instr(newtxt(1), ".") :- finds the position of the first full stop in the string
instr(newtxt(1), ".") -1 is the position before the full stop

for the sheet name you don't want to use add an if statement

e.g.
if worksheet.name <> "Allocation" then

the rest of the copy code inside

end if