#1
|
|||
|
|||
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 |
#2
|
||||
|
||||
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 |
#3
|
|||
|
|||
Hello Andrew,
Thank you for your reply but unfortunately still doesn't work. Much appreciated. Regards! |
#4
|
||||
|
||||
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 |
#5
|
|||
|
|||
can you post the workbook? much easier than just guessing what the code is trying to do
|
#6
|
|||
|
|||
Hi Purfleet, working on it. Need some time to reduced the number of files.
|
#7
|
|||
|
|||
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 Regards! |
#8
|
|||
|
|||
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. |
#9
|
|||
|
|||
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! |
#10
|
|||
|
|||
how do you know it didn't go all the way to the end?
|
#11
|
|||
|
|||
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") Again, thanks for the suggestion. |
|
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 |