Edit of exisiting Macro to subtotal Columns

spacey

New Member
Joined
Jul 3, 2008
Messages
8
Hi all...need help with a macro that I already have.
I have a spreadsheet with data in it & I run a macro to segregate the data according to a city or county in new sheets, while doing so, the macro renames the new sheets with city/county names.so I get new county sheets from main file with the respective county data from it...now I have columns in these sheets which have dollar amounts..I would like that when the main sheet is segregated into sheets as per the county/city or any other heading..the column which contains the dollar amounts, gets subtotalled at the bottom..irrespective of the number of rows in sheet.
the existing macro is below..

Sub FilterCities()
'last edited March 18, 2004
Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long
'include bottom most header row
Const TopLeftCellOfDataBase As String = "A9"
'what column has your key values
Const KeyColumn As String = "C"
'where's your data
Set DataBaseWks = Worksheets("Main")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = MsgBox("Include headings?", vbYesNo, "Headings")
Set TempWks = Worksheets.Add
With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With
'rebuild the List
With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True
'Add the heading to the criteria area
TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With
With TempWks
Set ListRange = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
End With
With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With
'check for individual City worksheets
For Each myCell In ListRange.Cells
If WksExists(myCell.Value) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = myCell.Value
If Err.Number <> 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear
End If
On Error GoTo 0
wks.Move After:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(myCell.Value)
wks.Cells.Clear
End If
If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value & Chr(34)
'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell
Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
MsgBox "Data has been sent"
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function


Column C is the onw which contains the counties...& A9 is where the data starts from.

Would appreciate if anyone can help me to edit this.

Thanks;)
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
You could try the following inserted between End If and the "Next myCell" statements...

Code:
rw = wks.Cells(1, 1).SpecialCells(xlLastCell).Row + 1
If rw > (i + 1) then
wks.Cells(rw, 15) = WorksheetFunction.Sum(wks.Range(Cells(i + 1, 15), Cells(rw - 1, 15)))
wks.Cells(rw, 16) = WorksheetFunction.Sum(wks.Range(Cells(i + 1, 16), Cells(rw - 1, 16)))
End If

NOTE: Untested as can't replicate....
 
Upvote 0
At top of routine alongside other Dim entries add

Code:
Dim rw As Long

i is your variable so should be defined already
 
Upvote 0
Mate...You are too Good!
Thanks for the help!

Need just one more solution..The county names are in Column C..so when the sheets get made..can I get Cell C10 get copied & pasted in Cell B1 in each respective sheet.
Cheers!
 
Upvote 0

Forum statistics

Threads
1,213,527
Messages
6,114,148
Members
448,552
Latest member
WORKINGWITHNOLEADER

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top