Excel VBA to Sum Based on Employee ID and Relation

[kwtx04rm]

Greetings,

I am trying to use VBA instead of the SUMPRODUCT formula shown below which I used for "Excel Formula to Sum Based on Employee ID" (see my earlier thread in the Microsoft: Office Forum).

=IF(NOT(AND(A3=A4,C3=C4)),SUMPRODUCT((EmployeeID=A3)*(Relation=C3)*(Premium)),"")

Btw, I tried using Excel's built-in Data > Subtotal feature, but it inserts rows to produce subtotals at each change of EmployeeID. I only need the subtotals to display one column to the right on change of Relation and EmployeeID. See example of expected results below:

EmployeeID Relation Premium Subtotal
123456789 E 9.71
123456789 E 8.60
123456789 E 11.31 29.62
987654320 D 6.50
987654320 D 6.50 13.00
987654320 E 11.50 11.50
987654320 S 12.00 12.50
654317157 E 16.50
654317157 E 13.00 29.50
654317157 S 14.00
654317157 S 10.25 24.25


I was able to modify Dave Pearson's VBA code to do most of what I need (

http://www.pcreview.co.uk/forums/thread-947459.php).

The modified VBA produces correct subtotals grouped by EmployeeID - which is OK.

However, I need help on getting the subtotals for each Relation (E= Employee, S= Spouse, C= Children) grouped by EmployeeID. Your assistance with this will be of great help!


This is the modified VBA code I am using:

Option Explicit
Sub SubTotalColumn()

Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim botCell As Range
Dim topCell As Range
Dim wks As Worksheet

Set wks = ActiveSheet

With wks
FirstRow = 2
.Rows(FirstRow).Insert
.Cells(FirstRow, "A").Value = "dummyVal"
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

Set topCell = .Cells(LastRow, "A")
Set botCell = .Cells(LastRow, "A")
For iRow = LastRow To FirstRow + 1 Step -1

If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value Then
Set topCell = .Cells(iRow - 1, "A")
Else

If topCell.Address = botCell.Address Then
topCell.Offset(0, 3).Value = topCell.Offset(0, 2).Value
Else

botCell.Offset(0, 3).Formula _
= "=subtotal(9," & topCell.Offset(0, 2).Address(0, 0) _
& ":" & botCell.Offset(0, 2).Address(0, 0) & ")"

End If
Set botCell = .Cells(iRow - 1, "A")
Set topCell = .Cells(iRow - 1, "A")
End If
Next iRow

.Rows(FirstRow).Delete

End With

End Sub

================================================

Here is the rest of sample data:

EmployeeID Relation Premium
123456789 E 9.71
123456789 E 8.60
123456789 E 11.31
987654320 D 6.50
987654320 D 6.50
987654320 E 11.50
987654320 S 12.00
654317157 E 16.50
654317157 E 13.00
654317157 S 14.00
654317157 S 10.25
336658854 D 7.75
336658854 D 6.50
222229375 E 20.50
222229375 E 21.50
222229375 S 26.00
555555959 E 20.50
777776637 E 19.20
777776637 E 24.30
123444119 D 6.50
123444119 D 6.50
123444119 D 7.00
123444119 D 7.00
123444119 E 20.50
123444119 E 28.00
222222280 D 6.50
222222280 D 6.50
222222280 D 6.50
222222280 E 19.10
222222280 E 20.00
222222280 S 30.00
222222280 S 34.70

 

[Gruuuu]

You don't need VBA for this.

'In Cell D2
=AND(A2=A3,B2=B3)

'In Cell E2
=IF(D2,"",SUM(C$2:C2)-SUM(E$1:E1))

Copy the formulas down.

If you prefer, hide the TRUE/FALSE column

 

[Gruuuu]

I'm sorry. Silly me

'In Cell D2
=IF(AND(A2=A3,B2=B3),"",SUM(C$2:C2)-SUM(D$1:D1))

There we are. Cleaner.

Also, BTW, this assumes that the data is sorted. Make sure it is before using these numbers.

If you must make this into a macro, make a macro to sort it and drop the formulas in