Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 09-09-2020, 01:15 PM
rsrasc rsrasc is offline Need Help with this Macro-Partially Working Windows 10 Need Help with this Macro-Partially Working Office 2013
Competent Performer
Need Help with this Macro-Partially Working
 
Join Date: Mar 2014
Location: Germany
Posts: 148
rsrasc is on a distinguished road
Default Need Help with this Macro-Partially Working

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
Reply With Quote
  #2  
Old 09-09-2020, 08:22 PM
Guessed's Avatar
Guessed Guessed is offline Need Help with this Macro-Partially Working Windows 10 Need Help with this Macro-Partially Working Office 2016
Expert
 
Join Date: Mar 2010
Location: Canberra/Melbourne Australia
Posts: 3,932
Guessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant future
Default

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
__________________
Andrew Lockton
Chrysalis Design, Melbourne Australia
Reply With Quote
  #3  
Old 09-09-2020, 10:47 PM
rsrasc rsrasc is offline Need Help with this Macro-Partially Working Windows 10 Need Help with this Macro-Partially Working Office 2013
Competent Performer
Need Help with this Macro-Partially Working
 
Join Date: Mar 2014
Location: Germany
Posts: 148
rsrasc is on a distinguished road
Default

Hello Andrew,

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

Much appreciated.

Regards!
Reply With Quote
  #4  
Old 09-09-2020, 11:16 PM
Guessed's Avatar
Guessed Guessed is offline Need Help with this Macro-Partially Working Windows 10 Need Help with this Macro-Partially Working Office 2016
Expert
 
Join Date: Mar 2010
Location: Canberra/Melbourne Australia
Posts: 3,932
Guessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant future
Default

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.
__________________
Andrew Lockton
Chrysalis Design, Melbourne Australia
Reply With Quote
  #5  
Old 09-09-2020, 11:53 PM
Purfleet Purfleet is offline Need Help with this Macro-Partially Working Windows 10 Need Help with this Macro-Partially Working Office 2019
Expert
 
Join Date: Jun 2020
Location: Essex
Posts: 345
Purfleet is a splendid one to beholdPurfleet is a splendid one to beholdPurfleet is a splendid one to beholdPurfleet is a splendid one to beholdPurfleet is a splendid one to beholdPurfleet is a splendid one to beholdPurfleet is a splendid one to behold
Default

can you post the workbook? much easier than just guessing what the code is trying to do
Reply With Quote
  #6  
Old 09-10-2020, 02:50 AM
rsrasc rsrasc is offline Need Help with this Macro-Partially Working Windows 10 Need Help with this Macro-Partially Working Office 2013
Competent Performer
Need Help with this Macro-Partially Working
 
Join Date: Mar 2014
Location: Germany
Posts: 148
rsrasc is on a distinguished road
Default

Hi Purfleet, working on it. Need some time to reduced the number of files.
Reply With Quote
  #7  
Old 09-10-2020, 03:59 AM
rsrasc rsrasc is offline Need Help with this Macro-Partially Working Windows 10 Need Help with this Macro-Partially Working Office 2013
Competent Performer
Need Help with this Macro-Partially Working
 
Join Date: Mar 2014
Location: Germany
Posts: 148
rsrasc is on a distinguished road
Default

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!
Attached Files
File Type: xlsm FY 21-SSX Budget File-PayrollOption2.xlsm (172.2 KB, 6 views)
File Type: xlsx 025 FY 2021 Expenses-SSX-Budget.xlsx (320.7 KB, 6 views)
File Type: xlsx 102 FY 2021 Expenses-SSX-Budget.xlsx (299.7 KB, 6 views)
Reply With Quote
  #8  
Old 09-10-2020, 08:53 AM
NoSparks NoSparks is offline Need Help with this Macro-Partially Working Windows 10 Need Help with this Macro-Partially Working Office 2010
Excel Hobbyist
 
Join Date: Nov 2013
Location: British Columbia, Canada
Posts: 831
NoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really nice
Default

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.
Reply With Quote
  #9  
Old 09-10-2020, 11:36 AM
rsrasc rsrasc is offline Need Help with this Macro-Partially Working Windows 10 Need Help with this Macro-Partially Working Office 2013
Competent Performer
Need Help with this Macro-Partially Working
 
Join Date: Mar 2014
Location: Germany
Posts: 148
rsrasc is on a distinguished road
Default

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!
Reply With Quote
  #10  
Old 09-10-2020, 11:44 AM
NoSparks NoSparks is offline Need Help with this Macro-Partially Working Windows 10 Need Help with this Macro-Partially Working Office 2010
Excel Hobbyist
 
Join Date: Nov 2013
Location: British Columbia, Canada
Posts: 831
NoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really nice
Default

how do you know it didn't go all the way to the end?
Reply With Quote
  #11  
Old 09-10-2020, 02:38 PM
rsrasc rsrasc is offline Need Help with this Macro-Partially Working Windows 10 Need Help with this Macro-Partially Working Office 2013
Competent Performer
Need Help with this Macro-Partially Working
 
Join Date: Mar 2014
Location: Germany
Posts: 148
rsrasc is on a distinguished road
Default

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.
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Need Help with this Macro-Partially Working Deleting rows with partially redundant data Noah14 Excel Programming 1 09-19-2014 11:46 PM
Need Help with this Macro-Partially Working 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

Other Forums: Access Forums

All times are GMT -7. The time now is 08:08 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft