Home |
Search |
Today's Posts |
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Adding Subtotal to Macro
This macro basically copies everything from a data sheet and splits it up
based by the account number, the problem I have is I need it to be able to copy a subtotal line at the bottom of the data table from sheet 1 to each worksheet, I tried putting something in, but it's not working out, if someone can have a look, it's commented. Also I added a print formating Sub, not sure If this is wrong or an easier way of doing this. Thanks so much to anyone, willing to help: sample data: D.C. WAYBILL # P.C. CODE LBS COST TAX TTL DC 0209 80281015331 B4V2V6 21 1 21.47 3.22 24.69 DC 0209 80281015836 B4V2V6 111 2 43.49 6.52 50.01 74.7 Sub Copy_With_AdvancedFilter_To_Worksheets() Dim CalcMode As Long Dim ws1 As Worksheet Dim WSNew As Worksheet Dim rng As Range Dim cell As Range Dim Lrow As Long Set ws1 = Sheets("Sheet1") '<<< Change 'Set ws1 = ActiveCell.CurrentRegion.Columns(KeyCol).Offset(1, 0).Cells 'Set ws1 = myArea.Resize(myArea.Rows.Count - 1, 1) 'Tip : Use a Dynamic range name, http://www.contextures.com/xlNames01.html#Dynamic 'or a fixed range like Range("A1:H1200") Set rng = ws1.Range("A1").CurrentRegion '<<< Change With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With With ws1 rng.Columns(1).AdvancedFilter _ Action:=xlFilterCopy, _ CopyToRange:=.Range("IV1"), Unique:=True 'This example filter on the first column in the range (change this if needed) 'You see that the last two columns of the worksheet are used to make a Unique list 'and add the CriteriaRange.(you can't use this macro if you use the columns) Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row .Range("IU1").Value = .Range("IV1").Value For Each cell In .Range("IV2:IV" & Lrow) .Range("IU2").Value = cell.Value Set WSNew = Sheets.Add Printing On Error Resume Next WSNew.Name = cell.Value If Err.Number 0 Then MsgBox "Change the name of : " & WSNew.Name & " manually" Err.CLEAR End If On Error GoTo 0 rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=.Range("IU1:IU2"), _ CopyToRange:=WSNew.Range("A1"), _ Unique:=False WSNew.Columns.AutoFit Next .Columns("IU:IV").CLEAR End With With Application .ScreenUpdating = True .Calculation = CalcMode End With End Sub Sub Printing() ' ' Printing Macro ' Macro recorded 10/3/2005 by Dejan Lukic ' ' With ActiveSheet.PageSetup .PrintTitleRows = "$1:$1" .PrintTitleColumns = "" End With ActiveSheet.PageSetup.PrintArea = "" With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "&F" .CenterFooter = "&A" .RightFooter = "&P OF &N" .LeftMargin = Application.InchesToPoints(0.75) .RightMargin = Application.InchesToPoints(0.75) .TopMargin = Application.InchesToPoints(1) .BottomMargin = Application.InchesToPoints(1) .HeaderMargin = Application.InchesToPoints(0.5) .FooterMargin = Application.InchesToPoints(0.5) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = True .CenterVertically = False .Orientation = xlLandscape .Draft = False .PaperSize = xlPaperLetter .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = False .PrintErrors = xlPrintErrorsDisplayed End With End Sub Sample data |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Adding Subtotal to Macro
Maybe...
If you find that last row of the worksheet, you can copy it when you create the new worksheets. I used column A to find the last row for the total and to find the lastrow for the new worksheet, too. Option Explicit Sub Copy_With_AdvancedFilter_To_Worksheets() Dim CalcMode As Long Dim ws1 As Worksheet Dim WSNew As Worksheet Dim rng As Range Dim cell As Range Dim Lrow As Long 'added Dim TotalRow As Range Set ws1 = Sheets("Sheet1") '<<< Change 'Set ws1 = ActiveCell.CurrentRegion.Columns(KeyCol).Offset(1, 0).Cells 'Set ws1 = myArea.Resize(myArea.Rows.Count - 1, 1) 'Tip : Use a Dynamic range name, 'http://www.contextures.com/xlNames01.html#Dynamic 'or a fixed range like Range("A1:H1200") Set rng = ws1.Range("A1").CurrentRegion '<<< Change With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With With ws1 'added Set TotalRow = .Cells(.Rows.Count, "A").End(xlUp).EntireRow rng.Columns(1).AdvancedFilter _ Action:=xlFilterCopy, _ CopyToRange:=.Range("IV1"), Unique:=True 'This example filter on the first column in the range (change this 'if needed) 'You see that the last two columns of the worksheet are used to make 'a Unique list 'and add the CriteriaRange.(you can't use this macro if you use the 'columns) Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row .Range("IU1").Value = .Range("IV1").Value For Each cell In .Range("IV2:IV" & Lrow) .Range("IU2").Value = cell.Value Set WSNew = Sheets.Add Printing On Error Resume Next WSNew.Name = cell.Value If Err.Number 0 Then MsgBox "Change the name of : " & WSNew.Name & " manually" Err.Clear End If On Error GoTo 0 rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=.Range("IU1:IU2"), _ CopyToRange:=WSNew.Range("A1"), _ Unique:=False 'added With WSNew TotalRow.Copy _ Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) End With WSNew.Columns.AutoFit Next .Columns("IU:IV").Clear End With With Application .ScreenUpdating = True .Calculation = CalcMode End With End Sub I didn't test it, but it compiled ok. Dejan wrote: This macro basically copies everything from a data sheet and splits it up based by the account number, the problem I have is I need it to be able to copy a subtotal line at the bottom of the data table from sheet 1 to each worksheet, I tried putting something in, but it's not working out, if someone can have a look, it's commented. Also I added a print formating Sub, not sure If this is wrong or an easier way of doing this. Thanks so much to anyone, willing to help: sample data: D.C. WAYBILL # P.C. CODE LBS COST TAX TTL DC 0209 80281015331 B4V2V6 21 1 21.47 3.22 24.69 DC 0209 80281015836 B4V2V6 111 2 43.49 6.52 50.01 74.7 Sub Copy_With_AdvancedFilter_To_Worksheets() Dim CalcMode As Long Dim ws1 As Worksheet Dim WSNew As Worksheet Dim rng As Range Dim cell As Range Dim Lrow As Long Set ws1 = Sheets("Sheet1") '<<< Change 'Set ws1 = ActiveCell.CurrentRegion.Columns(KeyCol).Offset(1, 0).Cells 'Set ws1 = myArea.Resize(myArea.Rows.Count - 1, 1) 'Tip : Use a Dynamic range name, http://www.contextures.com/xlNames01.html#Dynamic 'or a fixed range like Range("A1:H1200") Set rng = ws1.Range("A1").CurrentRegion '<<< Change With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With With ws1 rng.Columns(1).AdvancedFilter _ Action:=xlFilterCopy, _ CopyToRange:=.Range("IV1"), Unique:=True 'This example filter on the first column in the range (change this if needed) 'You see that the last two columns of the worksheet are used to make a Unique list 'and add the CriteriaRange.(you can't use this macro if you use the columns) Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row .Range("IU1").Value = .Range("IV1").Value For Each cell In .Range("IV2:IV" & Lrow) .Range("IU2").Value = cell.Value Set WSNew = Sheets.Add Printing On Error Resume Next WSNew.Name = cell.Value If Err.Number 0 Then MsgBox "Change the name of : " & WSNew.Name & " manually" Err.CLEAR End If On Error GoTo 0 rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=.Range("IU1:IU2"), _ CopyToRange:=WSNew.Range("A1"), _ Unique:=False WSNew.Columns.AutoFit Next .Columns("IU:IV").CLEAR End With With Application .ScreenUpdating = True .Calculation = CalcMode End With End Sub Sub Printing() ' ' Printing Macro ' Macro recorded 10/3/2005 by Dejan Lukic ' ' With ActiveSheet.PageSetup .PrintTitleRows = "$1:$1" .PrintTitleColumns = "" End With ActiveSheet.PageSetup.PrintArea = "" With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "&F" .CenterFooter = "&A" .RightFooter = "&P OF &N" .LeftMargin = Application.InchesToPoints(0.75) .RightMargin = Application.InchesToPoints(0.75) .TopMargin = Application.InchesToPoints(1) .BottomMargin = Application.InchesToPoints(1) .HeaderMargin = Application.InchesToPoints(0.5) .FooterMargin = Application.InchesToPoints(0.5) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = True .CenterVertically = False .Orientation = xlLandscape .Draft = False .PaperSize = xlPaperLetter .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = False .PrintErrors = xlPrintErrorsDisplayed End With End Sub Sample data -- Dave Peterson |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
sort macro, subtotal and add lines after subtotal | Excel Discussion (Misc queries) | |||
Macro add row and subtotal | Excel Discussion (Misc queries) | |||
macro excel subtotal in subtotal | Excel Discussion (Misc queries) | |||
Adding text to the subtotal row | Excel Worksheet Functions | |||
adding IF statement to subtotal for autofiltered data | Excel Worksheet Functions |