Need Help with this Macro-Partially Working

rsrasc · #1 09-09-2020, 01:15 PM

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

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Deleting rows with partially redundant data	Noah14	Excel Programming	1	09-19-2014 11:46 PM
partially delete agenda items	Gerreth	Outlook	3	03-13-2012 05:06 AM
Partially Obscure Video in PowerPoint	KBsay	PowerPoint	0	10-05-2010 12:49 PM
Problems working in a partially protected document	Autumn	Excel	0	02-11-2009 03:46 PM
Drawing partially off printed page	DLRA	Visio	0	09-26-2006 10:40 AM