Hi all,
For the record: All the code you will see here has been compiled from other sources and they are not mine.
I'm writing because I'm having problems when executing this part of the code. The problem is it will stop running.
Code:
Sub Transfer_Summary_Detail()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Summary")
Set Target = ActiveWorkbook.Worksheets("Sheet1")
j = 4 ' Start copying to row 1 in target sheet
For Each c In Source.Range("P4:P4000") ' Do 4000 rows
If c <> 0 Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
The above code is being run with the below Sub function ("Sub FY_21_SSX_Budget_File_Run1_Option2()", which has the six Call functions and the one that I'm having problem is for the following one.
"Call All_Macro4"
What is interesting is once the macro stop running I can go back, reset the macro and can rerun the Sub function for this macro individually (Sub Transfer_Summary_Detail(), which not issues.
I hope someone with the expertise can help me with this issue.
Also, if you have any suggestions on how to improve the code I'll be more than happy for that.
Thank you for your support!
Here below is all the code that I'm using:
Code:
Sub FY_21_SSX_Budget_File_Run1_Option2()
Call All_Macro1
Call All_Macro2
Call All_Macro3
Call All_Macro4
Call All_Macro5
Call All_Macro6
End Sub
Sub All_Macro1()
Call AddWorkSheet
Call CopyBudgetInfo
Call AutofitColumns
Call OpenUpFiles
End Sub
Sub All_Macro2()
Call CopyingDepartmentInformation
End Sub
Sub All_Macro3()
Call Copy_Dept_Info_To_Summary_025
Call Copy_Dept_Info_To_Summary_102
Call Copy_Dept_Info_To_Summary_350
Call Copy_Dept_Info_To_Summary_400
End Sub
Sub All_Macro4()
Call Transfer_Summary_Detail
End Sub
Sub All_Macro5()
Call Sum_Up_Column_AutoFitColumns_1
End Sub
Sub All_Macro6()
Call CloseAndSaveOpenWorkbooks
End Sub
Sub AddWorkSheet()
Worksheets.Add.Name = "400"
Worksheets.Add.Name = "350"
Worksheets.Add.Name = "102"
Worksheets.Add.Name = "025"
Worksheets.Add.Name = "Summary"
End Sub
Sub CopyBudgetInfo()
Dim w As Worksheet
For Each w In ThisWorkbook.Worksheets
w.Range("H1") = "2021 Budget"
w.Range("C2") = "1-Oct-20"
w.Range("D2") = "to"
w.Range("E2") = "30-Sep-21"
w.Range("C3") = "Beginning Balance - 2020"
w.Range("D3") = "Period 1 - 2020"
w.Range("E3") = "Period 2 - 2020"
w.Range("F3") = "Period 3 - 2020"
w.Range("G3") = "Period 4 - 2021"
w.Range("H3") = "Period 5 - 2021"
w.Range("I3") = "Period 6 - 2021"
w.Range("J3") = "Period 7 - 2021"
w.Range("K3") = "Period 8 - 2021"
w.Range("L3") = "Period 9 - 2021"
w.Range("M3") = "Period 10 - 2021"
w.Range("N3") = "Period 11 - 2021"
w.Range("O3") = "Period 12 - 2021"
w.Range("P3") = "Total"
w.Range("A3") = "Account"
w.Range("B2") = "Date Range"
w.Range("B3") = "Description"
Next w
End Sub
Sub AutofitColumns()
'Macro to autofit all columns in all worksheets
Dim sht As Worksheet
On Error Resume Next
For Each sht In ThisWorkbook.Worksheets
sht.Cells.SpecialCells(xlCellTypeVisible).Columns("A").AutoFit
sht.Cells.SpecialCells(xlCellTypeVisible).Columns("B").AutoFit
sht.Cells.SpecialCells(xlCellTypeVisible).Columns("C").AutoFit
sht.Cells.SpecialCells(xlCellTypeVisible).Columns("D:P").ColumnWidth = 12
sht.Cells.SpecialCells(xlCellTypeVisible).EntireColumn.Font.Name = "Calibri"
sht.Cells.SpecialCells(xlCellTypeVisible).EntireColumn.Font.Size = "9"
sht.Cells.SpecialCells(xlCellTypeVisible).Range("B2").HorizontalAlignment = xlCenter
sht.Cells.SpecialCells(xlCellTypeVisible).Range("B3").HorizontalAlignment = xlCenter
sht.Cells.SpecialCells(xlCellTypeVisible).Columns("A").ColumnWidth = 13
sht.Cells.SpecialCells(xlCellTypeVisible).Columns("B").ColumnWidth = 40
sht.Cells.SpecialCells(xlCellTypeVisible).Columns("A:B").HorizontalAlignment = xlLeft
Next sht
On Error GoTo 0
End Sub
Sub OpenUpFiles()
Workbooks.Open ("Z:\FY21 Budget\SSX Expenses\025 FY 2021 Expenses-SSX-Budget.xlsx"), UpdateLinks:=0
Workbooks.Open ("Z:\FY21 Budget\SSX Expenses\102 FY 2021 Expenses-SSX-Budget.xlsx"), UpdateLinks:=0
Workbooks.Open ("Z:\FY21 Budget\SSX Expenses\350 FY 2021 Expenses-SSX-Budget.xlsx"), UpdateLinks:=0
Workbooks.Open ("Z:\FY21 Budget\SSX Expenses\400 FY 2021 Expenses-SSX-Budget.xlsx"), UpdateLinks:=0
Application.DisplayAlerts = False
With ActiveSheet
.Cells.Font.Name = "Calibri"
.Cells.Font.Size = "10"
End With
End Sub
Sub CopyingDepartmentInformation()
Workbooks("025 FY 2021 Expenses-SSX-Budget.xlsx").Sheets("SummaryBudget-Payroll-Option2").Range("B4:Q98").Copy
Workbooks("FY 21-SSX Budget File-PayrollOption2.xlsm").Sheets("025").Range("A4:P98").PasteSpecial xlPasteValues
Workbooks("102 FY 2021 Expenses-SSX-Budget.xlsx").Sheets("SummaryBudget-Payroll-Option2").Range("B4:Q98").Copy
Workbooks("FY 21-SSX Budget File-PayrollOption2.xlsm").Sheets("102").Range("A4:P98").PasteSpecial xlPasteValues
Workbooks("350 FY 2021 Expenses-SSX-Budget.xlsx").Sheets("SummaryBudget-Payroll-Option2").Range("B4:Q98").Copy
Workbooks("FY 21-SSX Budget File-PayrollOption2.xlsm").Sheets("350").Range("A4:P98").PasteSpecial xlPasteValues
Workbooks("400 FY 2021 Expenses-SSX-Budget.xlsx").Sheets("SummaryBudget-Payroll-Option2").Range("B4:Q98").Copy
Workbooks("FY 21-SSX Budget File-PayrollOption2.xlsm").Sheets("400").Range("A4:P98").PasteSpecial xlPasteValues
With ActiveSheet
.Cells.Font.Name = "Calibri"
.Cells.Font.Size = "10"
End With
End Sub
Sub Copy_Dept_Info_To_Summary_025()
Dim wsSource As Worksheet, wsDest As Worksheet
Dim lastRow As Integer
Set wsSource = ThisWorkbook.Sheets("025")
Set wsDest = ThisWorkbook.Sheets("Summary")
lastRow = wsSource.Range("A" & Rows.Count).End(xlUp).Row
wsSource.Range("A4:P" & lastRow).Copy
With wsDest
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
.Range("A" & Rows.Count).End(xlUp).Copy .Range("A" & .Range("A" & Rows.Count).End(xlUp).Row & ":A" & .Range("B" & Rows.Count).End(xlUp).Row)
End With
End Sub
Sub Copy_Dept_Info_To_Summary_102()
Dim wsSource As Worksheet, wsDest As Worksheet
Dim lastRow As Integer
Set wsSource = ThisWorkbook.Sheets("102")
Set wsDest = ThisWorkbook.Sheets("Summary")
lastRow = wsSource.Range("A" & Rows.Count).End(xlUp).Row
wsSource.Range("A4:P" & lastRow).Copy
With wsDest
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
.Range("A" & Rows.Count).End(xlUp).Copy .Range("A" & .Range("A" & Rows.Count).End(xlUp).Row & ":A" & .Range("B" & Rows.Count).End(xlUp).Row)
End With
End Sub
Sub Copy_Dept_Info_To_Summary_350()
Dim wsSource As Worksheet, wsDest As Worksheet
Dim lastRow As Integer
Set wsSource = ThisWorkbook.Sheets("350")
Set wsDest = ThisWorkbook.Sheets("Summary")
lastRow = wsSource.Range("A" & Rows.Count).End(xlUp).Row
wsSource.Range("A4:P" & lastRow).Copy
With wsDest
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
.Range("A" & Rows.Count).End(xlUp).Copy .Range("A" & .Range("A" & Rows.Count).End(xlUp).Row & ":A" & .Range("B" & Rows.Count).End(xlUp).Row)
End With
End Sub
Sub Copy_Dept_Info_To_Summary_400()
Dim wsSource As Worksheet, wsDest As Worksheet
Dim lastRow As Integer
Set wsSource = ThisWorkbook.Sheets("400")
Set wsDest = ThisWorkbook.Sheets("Summary")
lastRow = wsSource.Range("A" & Rows.Count).End(xlUp).Row
wsSource.Range("A4:P" & lastRow).Copy
With wsDest
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
.Range("A" & Rows.Count).End(xlUp).Copy .Range("A" & .Range("A" & Rows.Count).End(xlUp).Row & ":A" & .Range("B" & Rows.Count).End(xlUp).Row)
End With
End Sub
Sub Transfer_Summary_Detail()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Summary")
Set Target = ActiveWorkbook.Worksheets("Sheet1")
j = 4 ' Start copying to row 1 in target sheet
For Each c In Source.Range("P4:P4000") ' Do 4000 rows
If c <> 0 Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
Sub Sum_Up_Column_AutoFitColumns_1()
'Macro to autofit all columns in all worksheets
Dim sht As Worksheet
On Error Resume Next
For Each sht In ThisWorkbook.Worksheets
sht.Cells.SpecialCells(xlCellTypeVisible).Range("P4:P230").Formula = "=SUM(D4:O4)"
sht.Cells.SpecialCells(xlCellTypeVisible).Range("P1").Formula = "=SUM(P4:P230)"
sht.Cells.SpecialCells(xlCellTypeVisible).Range("P1").NumberFormat = "$#,##0.00"
sht.Cells.SpecialCells(xlCellTypeVisible).Range("D4:P230").NumberFormat = "#,##0.00"
Next sht
On Error GoTo 0
End Sub
Sub CloseAndSaveOpenWorkbooks()
Dim Wkb As Workbook
With Application
.ScreenUpdating = False
' Loop through the workbooks collection
For Each Wkb In Workbooks
With Wkb
' if the book is read-only
' don't save but close
If Not Wkb.ReadOnly Then
.Save
End If
' We save this workbook, but we don't close it
' because we will quit Excel at the end,
' Closing here leaves the app running, but no books
If .Name <> ThisWorkbook.Name Then
.Close
End If
End With
Next Wkb
.ScreenUpdating = True
.Quit 'Quit Excel
End With
End Sub