VBA To automatically insert subtotals in multiple worksheets [Closed]

Report
Posts
2
Registration date
Sunday March 12, 2017
Status
Member
Last seen
March 12, 2017
-
Posts
2
Registration date
Sunday March 12, 2017
Status
Member
Last seen
March 12, 2017
-
Good Day, I hope somebody can help me, I have an workbook with a main sheet ""2017 Sales" and 10 worksheets with the name of each individual sales Agents, I have a macro that pulled all the information of the each sales Agents as I required, but I need sub totals to show as well on each sales persons worksheet, cant seem to get a macro to work so that I can see subtotals ????
This is the Current Code I have to pull the agents info from main sheet, I need to edit this so that it can pull subtotals as well under my Columns for each individual agent

Sub agents()
Dim ws As Worksheet
Dim wsNew As Worksheet
Dim rData As Range
Dim rCl As Range
Dim sNm As String
Set ws = Sheet1

'extract a list of unique names
'first clear existing list
With ws
Set rData = .Range("A1").CurrentRegion
.Columns(.Columns.Count).Clear
rData.Columns(6).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True

For Each rCl In .Cells(1, .Columns.Count).CurrentRegion
sNm = rCl.Text
'add new sheet (only if required-NB uses UDF)
If WksExists(sNm) Then
Sheets(sNm).Cells.Clear
Else
'new sheet required
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count) 'move to end
wsNew.Name = sNm
End If
'AutoFilter & copy to relevant sheet
rData.AutoFilter Field:=6, Criteria1:=sNm
rData.Copy Destination:=Worksheets(sNm).Cells(1, 1)
Next rCl
End With
ws.Columns(Columns.Count).ClearContents 'remove temporary list
rData.AutoFilter 'switch off AutoFilter

End Sub

Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function



Regards
Vicky

1 reply

Posts
2
Registration date
Sunday March 12, 2017
Status
Member
Last seen
March 12, 2017

Sorry this is the code I am currently running to pull the agents info from main sheet

Sub agents()
Dim ws As Worksheet
Dim wsNew As Worksheet
Dim rData As Range
Dim rCl As Range
Dim sNm As String
Set ws = Sheet1

'extract a list of unique names
'first clear existing list
With ws
Set rData = .Range("A1").CurrentRegion
.Columns(.Columns.Count).Clear
rData.Columns(6).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True

For Each rCl In .Cells(1, .Columns.Count).CurrentRegion
sNm = rCl.Text
'add new sheet (only if required-NB uses UDF)
If WksExists(sNm) Then
Sheets(sNm).Cells.Clear
Else
'new sheet required
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count) 'move to end
wsNew.Name = sNm
End If
'AutoFilter & copy to relevant sheet
rData.AutoFilter Field:=6, Criteria1:=sNm
rData.Copy Destination:=Worksheets(sNm).Cells(1, 1)
Next rCl
End With
ws.Columns(Columns.Count).ClearContents 'remove temporary list
rData.AutoFilter 'switch off AutoFilter

End Sub

Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function


Kind Regards

Hope somebody can help me, I am totally stuck