Adding Subtotal to Macro

[Dejan]

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]

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.