Hi All,
I am merging all workbooks within a particular directory. However, I do not reach the second part of this code which consolidates the first row of each merged sheet into the summary sheet (sheet2).
There appears to be a 30 sheet limitation. In other words, I can only merge upt o 30 files before I encounter an error that prevents the procedure from finishing.
Any thoughts?
Thanks.
David
Sub CreditReportCompile()
'
'
'
'Credit Report Compiler. Take Customer names from multiple docs and merge into a single credit report summary for upload to database.
Application.ScreenUpdating = False
Application.StatusBar = "Compiling..."
'set-up the credit report file based on an active workbook
'display message warning that current data will be lost - confirm
'*********************************
'merge workbooks into single sheet
'*********************************
'for each file listed in the specificed directory
Dim CurFile As String
Dim DestWB As Workbook
'define the location of files to be merged
Const DirLoc As String = "C:\CreditReport\"
'set-up the destination workbook
Set DestWB = Workbooks("Credit Report.xls")
'set the excel files to be merged location variable
CurFile = Dir(DirLoc & "*.xls")
'open the merge files within the defined directory
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
'open the original workbook
Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)
'copy analysis sheet data into fin sheet
'copy/move sheet 1 of the original workbook into the destination sheet (credit report summary workbook)
OrigWB.Sheets("fin").Move After:=DestWB.Sheets(DestWB.Sheets.Count)
'set all requried values to row 1
Range("A1").Value = Range("D5").Value
Range("B1").Value = Range("H6").Value
Range("C1").Value = Range("O5").Value
Range("D1").Value = Range("H8").Value
Range("E1").Value = Range("H9").Value
Range("F1").Value = Range("H11").Value
Range("G1").Value = Range("H17").Value
Range("H1").Value = Range("H26").Value
Range("I1").Value = Range("H30").Value
Range("J1").Value = Range("P16").Value
Range("K1").Value = Range("P8").Value
Range("L1").Value = Range("P23").Value
Range("M1").Value = Range("P24").Value
Range("N1").Value = Range("P29").Value
Range("O1").Value = Range("H34").Value
Range("P1").Value = Range("H36").Value
Range("Q1").Value = Range("H39").Value
Range("R1").Value = Range("H49").Value
Range("S1").Value = Range("P49").Value
'added to calculate sales growth value (found on analysis sheet)
'previous year revenue
Range("Z1").Value = Range("G34").Value
'rename the original workbook name so that it is no longer recognized as an excel file
CurFile = Left(Left(CurFile, Len(CurFile) - 4), 31)
'set the destination sheet name to the name of the original file
DestWB.Sheets(DestWB.Sheets.Count).Name = CurFile
'close the orginal workbook without making any changes
OrigWB.Close SaveChanges:=False
'set the current file directory back to active directory so that an error message does not appear
CurFile = Dir
Loop
Application.DisplayAlerts = False
'delete empty sheet 1 from the newly created destination workbook
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set DestWB = Nothing
'***************************************
'merge workbooks into single sheet -END-
'***************************************
'***********************************************
'format each sheet in the newly merged worksheet
'***********************************************
Application.DisplayAlerts = False
Sheets("Sheet3").Delete
Application.DisplayAlerts = True
Dim sh As Worksheet
For Each sh In Worksheets
If sh.Name <> "Sheet2" Then
Range("A1:Z1").Copy
Sheets("Sheet2").Activate
'copy row 1 to first empty row in sheet2
Lastrow = Cells(65536, 1).End(xlUp).Row + 1
Cells(Lastrow, 1).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
sh.Activate
Else
End If
Next
'*****************************************************
'format each sheet in the newly merged worksheet -END-
'*****************************************************
Sheets("Sheet2").Activate
'calculate sales revenue growth rate
Range("T2").Formula = "=(O2-Z2)/Z2"
'autofill to last row
Range("T2").AutoFill Destination:=Range("T2:T" & Cells(65536, 1).End(xlUp).Row)
'final formatting for summary sheet
'amounts
'percentage
'rename summary sheet
Sheets("Sheet2").Name = "Summary"
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
I am merging all workbooks within a particular directory. However, I do not reach the second part of this code which consolidates the first row of each merged sheet into the summary sheet (sheet2).
There appears to be a 30 sheet limitation. In other words, I can only merge upt o 30 files before I encounter an error that prevents the procedure from finishing.
Any thoughts?
Thanks.
David
Sub CreditReportCompile()
'
'
'
'Credit Report Compiler. Take Customer names from multiple docs and merge into a single credit report summary for upload to database.
Application.ScreenUpdating = False
Application.StatusBar = "Compiling..."
'set-up the credit report file based on an active workbook
'display message warning that current data will be lost - confirm
'*********************************
'merge workbooks into single sheet
'*********************************
'for each file listed in the specificed directory
Dim CurFile As String
Dim DestWB As Workbook
'define the location of files to be merged
Const DirLoc As String = "C:\CreditReport\"
'set-up the destination workbook
Set DestWB = Workbooks("Credit Report.xls")
'set the excel files to be merged location variable
CurFile = Dir(DirLoc & "*.xls")
'open the merge files within the defined directory
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
'open the original workbook
Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)
'copy analysis sheet data into fin sheet
'copy/move sheet 1 of the original workbook into the destination sheet (credit report summary workbook)
OrigWB.Sheets("fin").Move After:=DestWB.Sheets(DestWB.Sheets.Count)
'set all requried values to row 1
Range("A1").Value = Range("D5").Value
Range("B1").Value = Range("H6").Value
Range("C1").Value = Range("O5").Value
Range("D1").Value = Range("H8").Value
Range("E1").Value = Range("H9").Value
Range("F1").Value = Range("H11").Value
Range("G1").Value = Range("H17").Value
Range("H1").Value = Range("H26").Value
Range("I1").Value = Range("H30").Value
Range("J1").Value = Range("P16").Value
Range("K1").Value = Range("P8").Value
Range("L1").Value = Range("P23").Value
Range("M1").Value = Range("P24").Value
Range("N1").Value = Range("P29").Value
Range("O1").Value = Range("H34").Value
Range("P1").Value = Range("H36").Value
Range("Q1").Value = Range("H39").Value
Range("R1").Value = Range("H49").Value
Range("S1").Value = Range("P49").Value
'added to calculate sales growth value (found on analysis sheet)
'previous year revenue
Range("Z1").Value = Range("G34").Value
'rename the original workbook name so that it is no longer recognized as an excel file
CurFile = Left(Left(CurFile, Len(CurFile) - 4), 31)
'set the destination sheet name to the name of the original file
DestWB.Sheets(DestWB.Sheets.Count).Name = CurFile
'close the orginal workbook without making any changes
OrigWB.Close SaveChanges:=False
'set the current file directory back to active directory so that an error message does not appear
CurFile = Dir
Loop
Application.DisplayAlerts = False
'delete empty sheet 1 from the newly created destination workbook
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set DestWB = Nothing
'***************************************
'merge workbooks into single sheet -END-
'***************************************
'***********************************************
'format each sheet in the newly merged worksheet
'***********************************************
Application.DisplayAlerts = False
Sheets("Sheet3").Delete
Application.DisplayAlerts = True
Dim sh As Worksheet
For Each sh In Worksheets
If sh.Name <> "Sheet2" Then
Range("A1:Z1").Copy
Sheets("Sheet2").Activate
'copy row 1 to first empty row in sheet2
Lastrow = Cells(65536, 1).End(xlUp).Row + 1
Cells(Lastrow, 1).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
sh.Activate
Else
End If
Next
'*****************************************************
'format each sheet in the newly merged worksheet -END-
'*****************************************************
Sheets("Sheet2").Activate
'calculate sales revenue growth rate
Range("T2").Formula = "=(O2-Z2)/Z2"
'autofill to last row
Range("T2").AutoFill Destination:=Range("T2:T" & Cells(65536, 1).End(xlUp).Row)
'final formatting for summary sheet
'amounts
'percentage
'rename summary sheet
Sheets("Sheet2").Name = "Summary"
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub