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

Guessed · #2 09-09-2020, 08:22 PM

I'm not sure why it would stop running but it might be because you are comparing a range with a number. Also, I would copy the row to a the first cell rather than to an entire row. Try this

Code:

Sub Transfer_Summary_Detail()
  Dim c As Range, j As Integer
  Dim Source As Worksheet, Target As Worksheet

  Set Source = ActiveWorkbook.Worksheets("Summary")  ' Change worksheet designations as needed
  Set Target = ActiveWorkbook.Worksheets("Sheet1")
  
  j = 4     ' Start copying to 4th row in target sheet
  For Each c In Source.Range("P4:P4000")   ' Do 4000 rows
    If c.Value <> 0 Then
      Source.Rows(c.Row).Copy Target.Range("A" & j)
      j = j + 1
    End If
  Next c
End Sub

rsrasc · #3 09-09-2020, 10:47 PM

Hello Andrew,

Thank you for your reply but unfortunately still doesn't work.

Much appreciated.

Regards!

Guessed · #4 09-09-2020, 11:16 PM

Have you added break points in the code to work out where it is halting? Your Sum_Up_Column_AutoFitColumns_1 macro ignores all errors - are you sure it isn't actually working but hitting errors

I have noticed you have mixed and matched ActiveWorkbook and ThisWorkbook. These could be two different workbooks depending on where the code is sitting.

Purfleet · #5 09-09-2020, 11:53 PM

can you post the workbook? much easier than just guessing what the code is trying to do

rsrasc · #6 09-10-2020, 02:50 AM

Hi Purfleet, working on it. Need some time to reduced the number of files.

rsrasc · #7 09-10-2020, 03:59 AM

Hi all,

Here are the files as suggested.

The below code is part of the path that I'm using to open up the files. Please update it if necessary so you can open it.

Code:

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


Application.DisplayAlerts = False

With ActiveSheet
        .Cells.Font.Name = "Calibri"
        .Cells.Font.Size = "10"
        
    End With

End Sub

Again, thank you for your support!

Regards!

NoSparks · #8 09-10-2020, 08:53 AM

The macros should be in a standard module rather than ThisWorkbook module.

ThisWorkbook is always the workbook containing the code.

With what you've posted:
ActiveWorkbook is the last workbook opened by the OpenUpFiles macro and
ActiveSheet will be the sheet that was active at the time that file was last saved.

rsrasc · #9 09-10-2020, 11:36 AM

Hi NoSparks, as always thank you for your support.

As you suggested I moved the code to a standard module but I'm not sure or let say I don't know if what you mentioned about the ActviveWorkbook and the Active Sheet will allow the macro to run without any problems. I ran the code but didn't go all the way to the end.

Regards!

NoSparks · #10 09-10-2020, 11:44 AM

how do you know it didn't go all the way to the end?

rsrasc · #11 09-10-2020, 02:38 PM

Hi NoSparks, now I understand what you meant with the following:

ActiveWorkbook is the last workbook opened by the OpenUpFiles macro and
ActiveSheet will be the sheet that was active at the time that file was last saved.

This part of the below code was the problem.

Code:

' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Summary")    
Set Target = ActiveWorkbook.Worksheets("Sheet1")

Here below are the changes made to the code.

Code:

' Change worksheet designations as needed
Set Source = ThisWorkbook.Worksheets("Summary")
Set Target = ThisWorkbook.Worksheets("Sheet1")

Now the macro is running all the way to the end.

Again, thanks for the suggestion.

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

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