Looping through worksheets in a workbook and consolidating each workbook in to a worksheet in the master workbook - excel

Question

I have search and search for an answer to my code issue but I cant find any. I will be very grateful if someone can take a look at my code. At the moment, I have several large workbooks for data for each country. Each workbook has more that 5 work sheets. I want to consolidate the workbooks into a master file. First, I wan to copy and paste all worksheets under one work sheet in the master workbook and name it all by the country. Right now, my code is only able to consolidate one country at a time which makes it very slow. also the loop worksheet seems to the failing. It creates only one country worksheet. If I put in multiple country names, only the last country workbook gets consolidated. Something is missing but I cant seem to figure it out. Thank you so much!!!! Below is my code:
Sub consolidate()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim Masterwb As Workbook
Dim sh As Worksheet
Dim NewSht As Worksheet
Dim FindRng As Range
Dim PasteRow As Long
Dim countryname As String
Dim LastRow, Rowlast, Rowlast2 As Long
Const fr As Long = 2
Dim i As Long
Dim cell As Range
Dim wx As Worksheet
Set wx = ThisWorkbook.Sheets("Countryname")
Rowlast = wx.Range("B" & Rows.Count).End(xlDown).row 'selects list of country workbook I want to consolidate. e.g I could have Germany, usa, china
Rowlast2 = wx.Range("C" & Rows.Count).End(xlDown).row 'selects list of tabs for each country workbook I want to consolidate, e.g I want for every country listed above, that sheet names 1, 2, 3, 4 be consolidated and put in new worksheets in the masterfile
With wx
For LastRow = fr To Rowlast
If .Cells(LastRow, "B").Value <> "" Then
countryname = .Cells(LastRow, "B").Value
' set master workbook
Set Masterwb = Workbooks("ebele_test.xlsm")
folderPath = Application.InputBox(Prompt:= _
"Please enter only folder path in this format as C:\Users\... Exclude the file name", _
Title:="InputBox Method", Type:=2) 'Type:=2 = text
If folderPath = "False" Or IsError(folderPath) Then 'If Cancel is clicked on Input Box exit sub
MsgBox "Incorrect Input, Please paste correct folder path"
Exit Sub
'On Error GoTo 0
End If
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
Application.ScreenUpdating = False
Dim str As String
str = "Screener_User_Template-"
Filename = Dir(folderPath & str & countryname & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(folderPath & Filename)
If Len(wb.Name) > 253 Then
MsgBox "Sheet's name can be up to 253 characters long, shorten the Excel file name"
wb.Close False
GoTo Exit_Loop
Else
' add a new sheet with the file's name (remove the extension)
With Masterwb
Dim isLastSheet As Boolean
Dim ci, rows1 As Integer
Dim row As Long
rows1 = ThisWorkbook.Worksheets.Count
For ci = rows1 To 1 Step (-1)
If (isLastSheet) = False Then
Set NewSht = Masterwb.Worksheets.Add(After:=Worksheets(ci)) 'Place sheet at the end.
NewSht.Cells(1, 1) = "Identifier"
NewSht.Cells(1, 2) = "Company Name"
NewSht.Cells(1, 3) = "Country of Incorporation"
NewSht.Name = countryname
End If
Next ci
End With
End If
' loop through all sheets in opened wb
For Each sh In wb.Worksheets
For i = 2 To Rowlast2
If sh.Name = wx.Cells(i, "C").Value And NewSht.Name = countryname Then
' get the first empty row in the new sheet
Set FindRng = NewSht.Cells.Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not FindRng Is Nothing Then ' If find is successful
PasteRow = FindRng.row + 1
Else ' find was unsuccessfull > new empty sheet, should paste at the second row
PasteRow = 2
End If
Dim rng As Range
Set rng = sh.Range(sh.Cells(3, "A"), sh.Cells(150000, "M"))
rng.Copy
NewSht.Range("A" & PasteRow).PasteSpecial xlPasteValues
End If
Application.CutCopyMode = False 'Clears the clipboard
Next i
Next sh
wb.Close False
Exit_Loop:
Set wb = Nothing
Filename = Dir
Loop
End If
Next LastRow
End With
'0: Exit Sub
Application.ScreenUpdating = True
End Sub

Answer 1

It's a Mess
This is not a solution, just a work in progress which I cannot continue due to lack of information and knowledge. It could help you to finish what you started. It would be a shame to quit after you have invested so much time in it. If you provide some answers from the questions in the code someone else might help you finish it. The questions are by no means ironic, they're serious questions that I cannot answer for sure.
The code should be safe, but just don't save anything not to lose data.
I would suggest you somehow split such a code into several and ask several questions to get answers in the future.
Option Explicit
Sub Consolidate()
Application.EnableCancelKey = xlDisabled
' ThisWorkbook
Const cStrCountry As String = "CountryName"
Const cLngRow1 As Long = 2
' Tip: To use columns either as string or as integer declare them as Variant.
Const cVntColCountries As Variant = "B"
Const cVntColTabs As Variant = "C"
Const cStrTemplate = "Screener_User_Template-"
Const cStrMaster As String = "ebele_test.xlsm"
Const cStrExt = ".xlsx"
' New Worksheet in Master Workbook
Const cStrNewHeader1 = "Identifier"
Const cStrNewHeader2 = "Company Name"
Const cStrNewHeader3 = "Country of Incorporation"
' Each Worksheet in Each Workbook
Const cLngFirstRow As Long = 3
Const cLngLastRow As Long = 150000
' Tip: To use columns either as string or as integer declare them as Variant.
Const cVntFirstCol As Variant = "A"
Const cVntLastCol As Variant = "M"
' MsgBox
Dim strMsg1 As String
strMsg1 = "Please enter only folder path in this format as " _
& "C:\Users\... Exclude the file name"
Dim strMsg2 As String
strMsg2 = "Incorrect Input. Please paste correct folder path."
Dim strMsg3 As String
strMsg3 = "Sheet's name can only be up to 253 characters long. " _
& "Shorten the Excel file name."
' Workbooks
' ThisWorkbook
Dim ojbWbEach As Workbook ' Workbook Looper
Dim objWbMaster As Workbook ' Master Workbook
' Worksheets
' ThisWorkbook.Worksheets (cStrCountry)
Dim objWsEach As Worksheet ' Worksheet Looper
Dim objWsNew As Worksheet ' New Worksheet
' Arrays Pasted From Ranges
Dim vntCountries As Variant ' List of Countries
Dim vntTabs As Variant ' List of Tabs
' Ranges
Dim objRngEmpty As Range ' New Sheet Paste Cell
' Rows
Dim lngPasteRow As Long ' New Sheet Paste Row
Dim lngCountries As Long ' Countries Counter
Dim lngTabs As Long ' Tabs Counter
' Strings
Dim strPath As String
Dim strFile As String
Dim strCountry As String
With ThisWorkbook.Worksheets(cStrCountry)
' Paste list of countries from column cVntColCountries into array
vntCountries = .Range(.Cells(cLngRow1, cVntColCountries), _
.Cells(Rows.Count, cVntColCountries).End(xlUp)).Value2
' Paste list of tabs from column cVntColTabs into array
vntTabs = .Range(.Cells(cLngRow1, cVntColTabs), _
.Cells(Rows.Count, cVntColTabs).End(xlUp)).Value2
End With
' The data is in arrays instead of ranges.
' 1. According to the following line the workbook objWbMaster is already open.
' Is that true?
Set objWbMaster = Workbooks(cStrMaster)
For lngCountries = LBound(vntCountries) To UBound(vntCountries)
If vntCountries(lngCountries, 1) <> "" Then
strCountry = vntCountries(lngCountries, 1)
' Determine the path to search for files in.
strPath = Application.InputBox(Prompt:=strMsg1, _
Title:="InputBox Method", Type:=2) ' Type:=2 = text
' When Cancel is clicked in Input Box ... Exit Sub
If strPath = "False" Or IsError(strPath) Then
MsgBox strMsg2
Exit Sub
End If
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Application.ScreenUpdating = False
strFile = Dir(strPath & cStrTemplate & strCountry & "*" & cStrExt)
' VBA Help: Dir returns the first file name that matches pathname. To
' get any additional file names that match pathname, call Dir
' again with no arguments. When no more file names match, Dir
' returns a zero-length string ("").
' i.e. The approach is correct!
Do While strFile <> ""
Set ojbWbEach = Workbooks.Open(strPath & strFile)
' 2. When would this ever happen?
If Len(ojbWbEach.Name) <= 253 Then
' Add a new sheet with the file's name (remove the extension)
With objWbMaster
' 3. Isn't the blnLastSheet always False. What should it be doing?
Dim blnLastSheet As Boolean
Dim intSheetsCounter As Integer
Dim intSheets As Integer
intSheets = .Worksheets.Count
' 4. Why parentheses in ... Step (-1)?
For intSheetsCounter = intSheets To 1 Step -1
' 5. Why parentheses in (blnLastSheet)?
If (blnLastSheet) = False Then
' Place sheet at the end.
Set objWsNew = .Worksheets _
.Add(After:=.Worksheets(intSheetsCounter))
With objWsNew
.Cells(1, 1) = cStrNewHeader1
.Cells(1, 2) = cStrNewHeader2
.Cells(1, 3) = cStrNewHeader3
.Name = strCountry
End With
End If
Next
End With
Else
MsgBox strMsg3
ojbWbEach.Close False
GoTo Exit_Loop
End If
' Loop through all worksheets in ojbWbEach.
For Each objWsEach In ojbWbEach.Worksheets
With objWsEach
For lngTabs = LBound(vntTabs) To UBound(vntTabs)
If .Name = vntTabs(lngTabs) _
And objWsNew.Name = strCountry Then
' Get the first empty row in the new sheet
Set objRngEmpty = objWsNew.Cells.Find(What:="*", _
Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
' 6. I don't think that this is necessary because you added
' the headers to the New sheet so it will find the first
' row. Or am I missing something?
If Not objRngEmpty Is Nothing Then
' If find is successful.
lngPasteRow = objRngEmpty.row + 1
Else
' Find was unsuccessfull > new empty sheet.
' Should paste at the second row.
lngPasteRow = cLngRow1
End If
' if I'm right, delete all starting from "Set objRngEmpty ..."
' and delete "Dim objRngEmpty as Range" and use the following
' line:
' lngPasteRow = objWsNew.Cells.Find(What:="*", Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).row + 1
' Pasting a range into a same sized range is much faster than
' looping or copy/pasting.
objWsNew.Range(.Cells(lngPasteRow, cVntFirstCol), _
.Cells(cLngLastRow + lngPasteRow - cLngFirstRow, _
cVntLastCol)) = _
.Range(.Cells(cLngFirstRow, cVntFirstCol), _
.Cells(cLngLastRow, cVntLastCol)).Value2
End If
Next
.Close False
End With
Next
Exit_Loop:
Set ojbWbEach = Nothing
strFile = Dir
Loop
End If
Next lngCountries
Set objWsEach = Nothing
Set objWsNew = Nothing
Set objWbEach = Nothing
Set objWbMaster = Nothing
Application.ScreenUpdating = True
End Sub

Answer 2

Thank you again for the clean up. I made some modifications to your code and corrected some error but for some reason, it is only able to consolidate 7 countries after which excel crashes. See the code I am running below: Do you think you can find the issue?
Option Explicit
Sub Consolidate()
Application.EnableCancelKey = xlDisabled
' ThisWorkbook
Const cStrCountry As String = "CountryName"
Const cLngRow1 As Long = 2
' Tip: To use columns either as string or as integer declare them as Variant.
Const cVntColCountries As Variant = "B"
Const cVntColTabs As Variant = "C"
Const cStrTemplate = "Screener_User_Template-"
Const cStrMaster As String = "ebele_test.xlsm"
Const cStrExt = ".xlsx"
' New Worksheet in Master Workbook
Const cStrNewHeader1 = "Identifier"
Const cStrNewHeader2 = "Company Name"
Const cStrNewHeader3 = "Country of Incorporation"
' Each Worksheet in Each Workbook
Const cLngFirstRow As Long = 3
Const cLngLastRow As Long = 150000
' Tip: To use columns either as string or as integer declare them as Variant.
Const cVntFirstCol As Variant = "A"
Const cVntLastCol As Variant = "M"
' MsgBox
Dim strMsg1 As String
strMsg1 = "Please enter only folder path in this format as " _
& "C:\Users\... Exclude the file name"
Dim strMsg2 As String
strMsg2 = "Incorrect Input. Please paste correct folder path."
Dim strMsg3 As String
strMsg3 = "Sheet's name can only be up to 253 characters long. " _
& "Shorten the Excel file name."
' Workbooks
' ThisWorkbook
Dim ojbWbEach As Workbook ' Workbook Looper
Dim objWbMaster As Workbook ' Master Workbook
' Worksheets
' ThisWorkbook.Worksheets (cStrCountry)
Dim objWsEach As Worksheet ' Worksheet Looper
Dim objWsNew As Worksheet ' New Worksheet
' Arrays Pasted From Ranges
Dim vntCountries As Variant ' List of Countries
Dim vntTabs As Variant ' List of Tabs
' Ranges
Dim objRngEmpty As Range ' New Sheet Paste Cell
' Rows
Dim lngPasteRow As Long ' New Sheet Paste Row
Dim lngCountries As Long ' Countries Counter
Dim lngTabs As Long ' Tabs Counter
' Strings
Dim strPath As String
Dim strFile As String
Dim strCountry As String
With ThisWorkbook.Worksheets(cStrCountry)
' Paste list of countries from column cVntColCountries into array
vntCountries = .Range(.Cells(cLngRow1, cVntColCountries), _
.Cells(Rows.Count, cVntColCountries).End(xlUp)).Value2
' Paste list of tabs from column cVntColTabs into array
vntTabs = .Range(.Cells(cLngRow1, cVntColTabs), _
.Cells(Rows.Count, cVntColTabs).End(xlUp)).Value2
End With
' The data is in arrays instead of ranges.
' 1. According to the following line the workbook objWbMaster is already open.
' Is that true? yeah, but I moved the strpath up because I want it to be inputed once
Set objWbMaster = Workbooks(cStrMaster)
' Determine the path to search for files in.
strPath = Application.InputBox(Prompt:=strMsg1, _
Title:="InputBox Method", Type:=2) ' Type:=2 = text
'
For lngCountries = LBound(vntCountries) To UBound(vntCountries)
If vntCountries(lngCountries, 1) <> "" And strPath <> "" Then
strCountry = vntCountries(lngCountries, 1)
' When Cancel is clicked in Input Box ... Exit Sub
If strPath = "False" Or IsError(strPath) Then
MsgBox strMsg2
Exit Sub
End If
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Application.ScreenUpdating = False
strFile = Dir(strPath & cStrTemplate & strCountry & "*" & cStrExt)
' VBA Help: Dir returns the first file name that matches pathname. To
' get any additional file names that match pathname, call Dir
' again with no arguments. When no more file names match, Dir
' returns a zero-length string ("").
' i.e. The approach is correct!
Do While strFile <> ""
Set ojbWbEach = Workbooks.Open(strPath & strFile)
' 2. When would this ever happen?
If Len(ojbWbEach.Name) <= 253 Then
' Add a new sheet with the file's name (remove the extension)
With objWbMaster
' 3. Isn't the blnLastSheet always False. What should it be doing?
Dim blnLastSheet As Boolean
Dim intSheetsCounter As Integer
Dim intSheets As Integer
intSheets = .Worksheets.Count
' 4. Why parentheses in ... Step (-1)?
For intSheetsCounter = intSheets To 1 Step -1
' 5. Why parentheses in (blnLastSheet)?
If blnLastSheet = False Then
' Place sheet at the end.
Set objWsNew = .Worksheets _
.Add(After:=.Worksheets(intSheetsCounter))
With objWsNew
.Cells(1, 1) = cStrNewHeader1
.Cells(1, 2) = cStrNewHeader2
.Cells(1, 3) = cStrNewHeader3
End With
End If
Next
End With
Else
MsgBox strMsg3
ojbWbEach.Close False
GoTo Exit_Loop
End If
' Loop through all worksheets in ojbWbEach.
For Each objWsEach In ojbWbEach.Worksheets
With objWsEach
For lngTabs = LBound(vntTabs) To UBound(vntTabs)
If .Name = vntTabs(lngTabs, 1) Then
' _
'And objWsNew.Name = strCountry
'
' Get the first empty row in the new sheet
lngPasteRow = objWsNew.Cells.Find(What:="*", Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).row + 1
' Pasting a range into a same sized range is much faster than
' looping or copy/pasting.
objWsNew.Range(objWsNew.Cells(lngPasteRow, cVntFirstCol), _
objWsNew.Cells(cLngLastRow + lngPasteRow - cLngFirstRow, _
cVntLastCol)) = _
.Range(.Cells(cLngFirstRow, cVntFirstCol), _
.Cells(cLngLastRow, cVntLastCol)).Value2
objWsNew.Name = strCountry
End If
Next
End With
Next
ojbWbEach.Close False
Exit_Loop:
Set ojbWbEach = Nothing
strFile = Dir
Loop
End If
Next lngCountries
Set objWsEach = Nothing
Set objWsNew = Nothing
Set ojbWbEach = Nothing
Set objWbMaster = Nothing
Call Module2.clean
Application.ScreenUpdating = True
End Sub
What it does is that it also creates extra blank worksheets which I have to clean up with the sub clean.

Answer 3

This is a code from my consolidator maybe you can get an idea.
Dim lRow As Long
Dim LastRow As Long
lRow = Sheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Row
lRow = lRow + 100
LastRow = WorksheetFunction.Max(Sheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Row, 9)
LastRow = LastRow + 1
sht1.Range("A10:Q" & lRow).Copy
sht2.Range("A" & LastRow).PasteSpecial
Dim rowL As Long
rowL = sht1.Range("E65536").End(xlUp).Row
sht1.Range("B7").Copy Destination:=sht2.Range("R" & LastRow)
sht1.Range("D7").Copy Destination:=sht2.Range("S" & LastRow)