VBA Script for inserting new row and subtotal

[fali34533]

Hi I I am trying to apply a filter and sort the data by department.
for each department I want to add a new line to separate them and in that new row I want a subtotal of column labelled as "total" .

I've got the following in VBA so far and need help in inserting a subtotal in the new row for column total for each department.

Sub Insert_Rows_Sort_Department()
' Apply filter to Row 1
ActiveSheet.Range("A1").AutoFilter
' Sort data by "Department"
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add2 Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range("A:B")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Insert a row to separate each department
Dim lastRow As Long
lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = lastRow To 2 Step -1
If ActiveSheet.Cells(i, 2).Value <> ActiveSheet.Cells(i - 1, 2).Value Then
ActiveSheet.Rows(i).Insert Shift:=xlDown
End If
Next i


Any help will be much appriciated.

Thank you

 

[fali34533]

Hi I I am trying to apply a filter and sort the data by department.
for each department I want to add a new line to separate them and in that new row I want a subtotal of column labelled as "total" .

I've got the following in VBA so far and need help in inserting a subtotal in the new row for column total for each department.

Sub Insert_Rows_Sort_Department()
' Apply filter to Row 1
ActiveSheet.Range("A1").AutoFilter
' Sort data by "Department"
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add2 Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range("A:B")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Insert a row to separate each department
Dim lastRow As Long
lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = lastRow To 2 Step -1
If ActiveSheet.Cells(i, 2).Value <> ActiveSheet.Cells(i - 1, 2).Value Then
ActiveSheet.Rows(i).Insert Shift:=xlDown
End If
Next i


Any help will be much appriciated.

Thank you

I want the out put to look like this
Name Department Total
Test1 Food 1
Test2 Food 1
Subtotal 2
Test4 Bills 4
Test4 Bills 1
Subtotal 5