Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Subtotal for same range of multiple worksheets
Hi,
I have a workbook where data is compiled through out the year and has to be re-ran from the beginning of the year each month due to changes in open orders. I also have worksheets breaking down each month, but it has become a problem recreating the worksheets each month. I have code (from Ron de Bruin) to create a worksheet for each month ("01-09", "02-09", etc.). Now, I want to save the workbook (ActiveWorkbook.Save) after the pages are created and run the following code for worksheets named 01-09, 02-09, etc. This will work for one worksheet, but I can't seem to find the right code to make it work for an array of worksheets. It will sort and subtotal specified columns and then bold total rows and insert a row after each total row. Sub Total_Worksheets() Dim rng As Range Range("A1:p900").Select Selection.Sort Key1:=Range("c2"), Order1:=xlAscending, _ Key2:=Range("A2"), Order2:=xlAscending, _ Key2:=Range("b2"), Order2:=xlAscending, _ Header:=xlYes With Sheets("02-09") On Error Resume Next Set rng = Range(Range("j2"), Cells(2, Columns.Count).End(xlToLeft)) On Error GoTo 0 If Not rng Is Nothing Then .Range("j2").Subtotal _ GroupBy:=3, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=1, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=2, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True End If End With Dim LastRow As Long Dim r As Long LastRow = Range("G" & Rows.Count).End(xlUp).Row For r = LastRow To 2 Step -1 If InStr(1, Cells(r, 1).Value, "Total") 0 Or _ InStr(1, Cells(r, 2).Value, "Total") 0 Or _ InStr(1, Cells(r, 3).Value, "Total") 0 Or _ InStr(1, Cells(r, 4).Value, "Total") 0 Then Range(Cells(r, 1), Cells(r, 30)).Font.Bold = True ActiveSheet.Rows(r + 1).EntireRow.Insert End If Next End Sub If this is possible to do over multiple sheets, I would really appreciate code to make it work. Thanks in advance, Phisaw |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Subtotal for same range of multiple worksheets
Try the following. Code is untested. Backup your workbook first and note the comments in the code. Sub Total_Worksheets() Dim ws As Worksheet Dim rng As Range 'If you want to select a range, ensure the correct 'worksheet is selected first or it will have errors 'because it selects on the currently active worksheet. 'Edit SheetName to your sheet name. Sheets("SheetName").Select 'or 'Sheets ws.Select 'See next comment Range("A1:p900").Select Selection.Sort Key1:=Range("c2"), Order1:=xlAscending, _ Key2:=Range("A2"), Order2:=xlAscending, _ Key2:=Range("b2"), Order2:=xlAscending, _ Header:=xlYes 'Not sure if the following line needs to be before 'or after the previous code. For Each ws In Worksheets 'Could insert an if statement here like the 'following to exclude any specific worksheets 'If ws.Name = "MainMenu" Or ws.Name = "Totals" Then ' GoTo SkipSheet 'End If 'With Sheets("02-09") 'Use next line in lieu With ws On Error Resume Next Set rng = Range(Range("j2"), Cells(2, Columns.Count).End(xlToLeft)) On Error GoTo 0 If Not rng Is Nothing Then .Range("j2").Subtotal _ GroupBy:=3, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=1, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=2, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True End If End With Dim LastRow As Long Dim r As Long LastRow = Range("G" & Rows.Count).End(xlUp).Row For r = LastRow To 2 Step -1 If InStr(1, Cells(r, 1).Value, "Total") 0 Or _ InStr(1, Cells(r, 2).Value, "Total") 0 Or _ InStr(1, Cells(r, 3).Value, "Total") 0 Or _ InStr(1, Cells(r, 4).Value, "Total") 0 Then Range(Cells(r, 1), Cells(r, 30)).Font.Bold = True ActiveSheet.Rows(r + 1).EntireRow.Insert End If Next 'SkipSheet: 'Uncomment if using skip worksheets Next ws End Sub -- Regards, OssieMac |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Subtotal for same range of multiple worksheets
OssieMac,
Thanks for replying with code and comments. Is there any way to select just the sheets to sort - I have way more not to sort than the 12 I need sorted. Thanks, Phisaw "OssieMac" wrote: Try the following. Code is untested. Backup your workbook first and note the comments in the code. Sub Total_Worksheets() Dim ws As Worksheet Dim rng As Range 'If you want to select a range, ensure the correct 'worksheet is selected first or it will have errors 'because it selects on the currently active worksheet. 'Edit SheetName to your sheet name. Sheets("SheetName").Select 'or 'Sheets ws.Select 'See next comment Range("A1:p900").Select Selection.Sort Key1:=Range("c2"), Order1:=xlAscending, _ Key2:=Range("A2"), Order2:=xlAscending, _ Key2:=Range("b2"), Order2:=xlAscending, _ Header:=xlYes 'Not sure if the following line needs to be before 'or after the previous code. For Each ws In Worksheets 'Could insert an if statement here like the 'following to exclude any specific worksheets 'If ws.Name = "MainMenu" Or ws.Name = "Totals" Then ' GoTo SkipSheet 'End If 'With Sheets("02-09") 'Use next line in lieu With ws On Error Resume Next Set rng = Range(Range("j2"), Cells(2, Columns.Count).End(xlToLeft)) On Error GoTo 0 If Not rng Is Nothing Then .Range("j2").Subtotal _ GroupBy:=3, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=1, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=2, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True End If End With Dim LastRow As Long Dim r As Long LastRow = Range("G" & Rows.Count).End(xlUp).Row For r = LastRow To 2 Step -1 If InStr(1, Cells(r, 1).Value, "Total") 0 Or _ InStr(1, Cells(r, 2).Value, "Total") 0 Or _ InStr(1, Cells(r, 3).Value, "Total") 0 Or _ InStr(1, Cells(r, 4).Value, "Total") 0 Then Range(Cells(r, 1), Cells(r, 30)).Font.Bold = True ActiveSheet.Rows(r + 1).EntireRow.Insert End If Next 'SkipSheet: 'Uncomment if using skip worksheets Next ws End Sub -- Regards, OssieMac |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Subtotal for same range of multiple worksheets
The following should do what you want. I now see I had a couple of errors in
my previous code but perhaps you picked them up. As before, the code is untested but I did at least compile it this time. The Select Case is a better way than if statements to select from a list of sheets. So easy to just edit the list of sheet names. Sub Total_Worksheets() Dim ws As Worksheet Dim rng As Range For Each ws In Worksheets Select Case ws.Name 'All sheet names listed in the case statement 'will be processed. Change the names I have 'used to your sheet names and add your 'additional sheet names separated by commas. Case "Sheet1", "Sheet2", "Sheet3", "Sheet4" ws.Select Range("A1:p900").Select Selection.Sort Key1:=Range("c2"), _ Order1:=xlAscending, _ Key2:=Range("A2"), Order2:=xlAscending, _ Key2:=Range("b2"), Order2:=xlAscending, _ Header:=xlYes On Error Resume Next 'Following line references active sheet so 'do not nest inside the With/End With Set rng = Range(Range("j2"), _ Cells(2, Columns.Count).End(xlToLeft)) On Error GoTo 0 If Not rng Is Nothing Then With ws .Range("j2").Subtotal _ GroupBy:=3, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=1, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=2, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True End With End If Dim LastRow As Long Dim r As Long 'Following code references active sheet so 'do not nest inside the With/End With LastRow = Range("G" & Rows.Count).End(xlUp).Row For r = LastRow To 2 Step -1 If InStr(1, Cells(r, 1).Value, "Total") 0 Or _ InStr(1, Cells(r, 2).Value, "Total") 0 Or _ InStr(1, Cells(r, 3).Value, "Total") 0 Or _ InStr(1, Cells(r, 4).Value, "Total") 0 Then Range(Cells(r, 1), Cells(r, 30)).Font.Bold = True ActiveSheet.Rows(r + 1).EntireRow.Insert End If Next End Select 'End of Case Next ws End Sub -- Regards, OssieMac |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Subtotal for same range of multiple worksheets
OssieMac,
It works! Thank you soooooo much!! I have one more piece of code that I can't quite get to work as I want. Thanks to Jim Thomlinson, I used code he supplied to another poster but with my modification to fit my spreadsheet there is just a cosmetic flaw I would like to take care of. On the second part of the following code (for column B) after I .resize (,15) it doesn't highlight column A. I can't choose ..entirerow, because I have other data past column P that I don't want highlighted. What code do I use to have it highlight A:P when word "Total" is in Column B? Dim rngFound As Range Dim strFirstAddress As String 'Search slsp for Total rows Set rngFound = Columns("A").Find(What:="total", _ LookAt:=xlPart, _ LookIn:=xlValues, _ MatchCase:=False) If Not rngFound Is Nothing Then strFirstAddress = rngFound.Address Do rngFound.Resize(, 16).Interior.ColorIndex = 17 Set rngFound = Columns("A").FindNext(rngFound) Loop Until rngFound.Address = strFirstAddress End If 'Search Class for Total rows Set rngFound = Columns("B").Find(What:="total", _ LookAt:=xlPart, _ LookIn:=xlValues, _ MatchCase:=False) If Not rngFound Is Nothing Then strFirstAddress = rngFound.Address Do rngFound.Resize(, 15).Interior.ColorIndex = 6 Set rngFound = Columns("B").FindNext(rngFound) Loop Until rngFound.Address = strFirstAddress End If Thanks again for all your help, Phisaw "OssieMac" wrote: The following should do what you want. I now see I had a couple of errors in my previous code but perhaps you picked them up. As before, the code is untested but I did at least compile it this time. The Select Case is a better way than if statements to select from a list of sheets. So easy to just edit the list of sheet names. Sub Total_Worksheets() Dim ws As Worksheet Dim rng As Range For Each ws In Worksheets Select Case ws.Name 'All sheet names listed in the case statement 'will be processed. Change the names I have 'used to your sheet names and add your 'additional sheet names separated by commas. Case "Sheet1", "Sheet2", "Sheet3", "Sheet4" ws.Select Range("A1:p900").Select Selection.Sort Key1:=Range("c2"), _ Order1:=xlAscending, _ Key2:=Range("A2"), Order2:=xlAscending, _ Key2:=Range("b2"), Order2:=xlAscending, _ Header:=xlYes On Error Resume Next 'Following line references active sheet so 'do not nest inside the With/End With Set rng = Range(Range("j2"), _ Cells(2, Columns.Count).End(xlToLeft)) On Error GoTo 0 If Not rng Is Nothing Then With ws .Range("j2").Subtotal _ GroupBy:=3, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=1, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=2, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True End With End If Dim LastRow As Long Dim r As Long 'Following code references active sheet so 'do not nest inside the With/End With LastRow = Range("G" & Rows.Count).End(xlUp).Row For r = LastRow To 2 Step -1 If InStr(1, Cells(r, 1).Value, "Total") 0 Or _ InStr(1, Cells(r, 2).Value, "Total") 0 Or _ InStr(1, Cells(r, 3).Value, "Total") 0 Or _ InStr(1, Cells(r, 4).Value, "Total") 0 Then Range(Cells(r, 1), Cells(r, 30)).Font.Bold = True ActiveSheet.Rows(r + 1).EntireRow.Insert End If Next End Select 'End of Case Next ws End Sub -- Regards, OssieMac |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Subtotal for same range of multiple worksheets
Sorry I didn't get back to you sooner but I have been away. Anyway if you
have not already got your answer then try the following. rngFound.Offset(0, -1).Resize(, 16).Interior.ColorIndex = 6 Another option is. Range(Cells(rngFound.Row, "A"), _ Cells(rngFound.Row, "P")) _ .Interior.ColorIndex = 6 -- Regards, OssieMac "PHisaw" wrote: OssieMac, It works! Thank you soooooo much!! I have one more piece of code that I can't quite get to work as I want. Thanks to Jim Thomlinson, I used code he supplied to another poster but with my modification to fit my spreadsheet there is just a cosmetic flaw I would like to take care of. On the second part of the following code (for column B) after I .resize (,15) it doesn't highlight column A. I can't choose .entirerow, because I have other data past column P that I don't want highlighted. What code do I use to have it highlight A:P when word "Total" is in Column B? Dim rngFound As Range Dim strFirstAddress As String 'Search slsp for Total rows Set rngFound = Columns("A").Find(What:="total", _ LookAt:=xlPart, _ LookIn:=xlValues, _ MatchCase:=False) If Not rngFound Is Nothing Then strFirstAddress = rngFound.Address Do rngFound.Resize(, 16).Interior.ColorIndex = 17 Set rngFound = Columns("A").FindNext(rngFound) Loop Until rngFound.Address = strFirstAddress End If 'Search Class for Total rows Set rngFound = Columns("B").Find(What:="total", _ LookAt:=xlPart, _ LookIn:=xlValues, _ MatchCase:=False) If Not rngFound Is Nothing Then strFirstAddress = rngFound.Address Do rngFound.Resize(, 15).Interior.ColorIndex = 6 Set rngFound = Columns("B").FindNext(rngFound) Loop Until rngFound.Address = strFirstAddress End If Thanks again for all your help, Phisaw "OssieMac" wrote: The following should do what you want. I now see I had a couple of errors in my previous code but perhaps you picked them up. As before, the code is untested but I did at least compile it this time. The Select Case is a better way than if statements to select from a list of sheets. So easy to just edit the list of sheet names. Sub Total_Worksheets() Dim ws As Worksheet Dim rng As Range For Each ws In Worksheets Select Case ws.Name 'All sheet names listed in the case statement 'will be processed. Change the names I have 'used to your sheet names and add your 'additional sheet names separated by commas. Case "Sheet1", "Sheet2", "Sheet3", "Sheet4" ws.Select Range("A1:p900").Select Selection.Sort Key1:=Range("c2"), _ Order1:=xlAscending, _ Key2:=Range("A2"), Order2:=xlAscending, _ Key2:=Range("b2"), Order2:=xlAscending, _ Header:=xlYes On Error Resume Next 'Following line references active sheet so 'do not nest inside the With/End With Set rng = Range(Range("j2"), _ Cells(2, Columns.Count).End(xlToLeft)) On Error GoTo 0 If Not rng Is Nothing Then With ws .Range("j2").Subtotal _ GroupBy:=3, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=1, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=2, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True End With End If Dim LastRow As Long Dim r As Long 'Following code references active sheet so 'do not nest inside the With/End With LastRow = Range("G" & Rows.Count).End(xlUp).Row For r = LastRow To 2 Step -1 If InStr(1, Cells(r, 1).Value, "Total") 0 Or _ InStr(1, Cells(r, 2).Value, "Total") 0 Or _ InStr(1, Cells(r, 3).Value, "Total") 0 Or _ InStr(1, Cells(r, 4).Value, "Total") 0 Then Range(Cells(r, 1), Cells(r, 30)).Font.Bold = True ActiveSheet.Rows(r + 1).EntireRow.Insert End If Next End Select 'End of Case Next ws End Sub -- Regards, OssieMac |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Copying a range of data across multiple worksheets | Excel Programming | |||
Copying a range of data across multiple worksheets | Excel Programming | |||
Sum same cell/range of multiple worksheets within a workbook... | Excel Worksheet Functions | |||
same named range on multiple worksheets? | Excel Discussion (Misc queries) | |||
range problem with multiple use of subtotal function | Excel Programming |