I have several Excel files in a folder that I need to be formatted, and then the resultant files merged into one master spreadsheet.
1. I have the code to open all the files in the specified folder as follows:
Sub Open_Workbooks()
Dim myPath As String
Dim myFile As String
Dim wb As Workbook
' Specify the folder path containing the Excel files
myPath = "C:\Users\Kuda\Documents\TRIAL BALANCES"
' Check for trailing backslash in folder path
If Right(myPath, 1) <> "\" Then myPath = myPath & "\"
' Find the first Excel file in the folder
myFile = Dir(myPath & "*.xls*")
' Loop through all Excel files in the folder
Do While myFile <> ""
' Open the workbook
Set wb = Workbooks.Open(myPath & myFile)
' Move to the next file (this line is essential to avoid an endless loop)
myFile = Dir
Loop
End Sub
2. The formatting code will be:
Call tb_cleanup()
3. Now I need a 3rd code that applies code #2 to all the open spreadsheets, and then copies the formatted data from each open spreadsheet, and then pastes it, stacking them one after the other onto one master spreadsheet.
#4 The Fourth code would be one singular code which has the above 3 all in one.
So, could I get help with a code for point 3 & 4 as per the above.
The code for tb-cleanup is
Sub tb_cleanup()
Dim A, B
If Range("D11").Value <> "Account" Then
MsgBox "Not applicable here.", vbOKOnly, "FOR TB ONLY!!"
Exit Sub
End If
Application.ScreenUpdating = False
A = Range("A2").Value
B = Range("B2").Value
Cells.Select
Selection.UnMerge
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Rows("1:10").Select
Range("A10").Activate
Selection.Delete Shift:=xlUp
Range("G1").Value = "Business Unit"
Range("H1").Value = "Month"
Range("I1").Value = "Year"
Dim xRow
xRow = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas2, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
, SearchFormat:=False).Row
Dim k
k = xRow - 5
' delete last unnec rows
Rows(k & ":" & xRow).Select
Selection.Delete Shift:=xlUp
xRow = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas2, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
, SearchFormat:=False).Row
'put BU + Date
Range("G2:G" & xRow).FormulaR1C1 = A
Range("H2:H" & xRow).FormulaR1C1 = Format(B, "MMM")
Range("I2:I" & xRow).FormulaR1C1 = Format(B, "yyyy")
Range("G2").Select
Range("B2").Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveWindow.FreezePanes = True
Range("A1:I" & xRow).Select
Selection.Columns.AutoFit
Range("G2").Select
Call myTable
xRow = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas2, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
, SearchFormat:=False).Row
Range("B2:B" & xRow).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.InsertIndent 1
ActiveWindow.Zoom = 75
Range("A1:I" & xRow).Select
Selection.RowHeight = 18
With Selection
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = -1
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Font
.Name = "Aptos Display"
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontMajor
End With
With Selection.Font
.Name = "Aptos Display"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontMajor
End With
Range("D2:F" & xRow).Select
Selection.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
Range("A1:I" & xRow).Select
Selection.Columns.AutoFit
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
Range("A1").Select
Application.ScreenUpdating = True
End Sub
call myTable is as follows:
Sub myTable()
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Font.Bold = True
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Cells.EntireColumn.AutoFit
Range("A1").Select
End Sub
Instead of opening all files at once and making the modifications, this will open them individually 1 by 1 and loop through the entire folder until complete.
1. Create a master file in your folder location and name it "1. File Consolidator". Make sure all the files in the folder being opened by the Master File are in .xlsb format (or if different, change the extension type in the "AllFiles" macro below).
2. Open the master file and re-name the tab to "File Consolidator".
3. Create a macro in which you will run:
Sub AllFiles()
Dim folderPath As String
Dim filename As String
Dim wb As Workbook
Dim wb2 As Workbook
folderPath = ActiveWorkbook.Path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
filename = Dir(folderPath & "*.xlsb")
Do While filename <> ""
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(folderPath & filename)
'Call a subroutine here to operate on the just-opened workbook
Call tb_cleanup
'Call 2nd subroutine to copy and paste opened workbook into master file
Call GenFileToCall
filename = Dir
Loop
Application.ScreenUpdating = True
MsgBox ("File Consolidator ran successfully")
End Sub
Create your 2nd macro "GenFileToCall" (called in the above), to copy the open workbooks to your master file:
Sub GenFileToCall()
Dim Lastrow As Long
Set wb = Application.Workbooks("1. File Consolidator.xlsm")
Set wb2 = Application.ActiveWorkbook
If ActiveSheet.FilterMode Then wb2.Sheets("Sheet1").ShowAllData
'Find last row in wb2
With wb2.Sheets("Sheet1")
Lastrow = .Range("A:AS").Find("*", , , , xlByRows, xlPrevious).Row
End With
'Copy range from A2:AS until last row then close
wb2.Sheets("Sheet1").Range("A2:AS" & Lastrow).Copy
Application.DisplayAlerts = False
'Make wb1 active workbook again
wb.Activate
'Find last row in wb1
With wb.Sheets("File Consolidator")
Lastrow = .Range("A:AS").Find("*", , , , xlByRows, xlPrevious).Row
End With
'Paste in wb1 after last row
wb.Sheets("File Consolidator").Range("A" & Lastrow + 1).PasteSpecial xlPasteValues
wb.Sheets("File Consolidator").Range("A" & Lastrow + 1).PasteSpecial xlPasteFormats
'Close wb2 (Test File)
wb2.Close
End Sub