Subtotals and Conditional Formatting

[1kat]

I need to regularly scan a large excel spreadsheet that has a Subtotal filter applied to it. I need to find and highlight specific Subtotal Groups that match a criteria.

Below is a screenshot of my example.

My criteria is, if a subtotal group has the same Teller (column C) for all of the lines in that group then I need to identify that group either by highlighting the whole group or just one row in it. I just need to easily scroll through the spreadsheet and find the groups where all the tellers are the same.

In my below example, the second group matches my criteria (rows 11-15) because all the tellers are john.

I would really appreciate some help as I've been messing with this for quite some time and cannot figure out how to do it. It's fine if the solution is not using conditional formatting to highlight the groups, I just need to be able to easily identify the groups where the tellers are all the same without having to scroll through the entire spreadsheet to manually pick them out myself.

Thanks in advance!

 

[venkat1926]

I was not able to transfer to gif into excel. So I prepared a sample data as below

Excel Workbook
	A	B	C	D	E	F	G
1	hdng1	hdng2	hdng3	hdng4	hdng5	hdng6	hdng7
2			john
3			john
4			david
5			david
6				michael count	4
7			john
8			john
9			john
10			john
11				david countg	4
12			jane
13			jane
14			jane
15			david
16			david
17			david
18			david
19			david
20				nicole count	8
Sheet1

on this sample try this macro

Sub test()
Dim r As Range, r1 As Range, add As String
Dim j As Integer, k As Integer
Set r = Range("D1")
Set r1 = Columns("D:D").Cells.Find(what:="count", lookat:=xlPart)
add = r1.Address
j = WorksheetFunction.CountA(Range(Cells(r.Row, "C"), Cells(r1.Row, "C")))
k = WorksheetFunction.CountIf(Range(Cells(r.Row, "C"), Cells(r1.Row, "C")), r1.Offset(-1, -1))
If j = k Then
Cells(r1.Row, "C").EntireRow.ColorIndex = 3
End If
Do
Set r = r1
Set r1 = Cells.FindNext(r1)
If r1 Is Nothing Then Exit Do
If r1.Address = add Then Exit Do
j = WorksheetFunction.CountA(Range(Cells(r.Row, "C"), Cells(r1.Row, "C")))
k = WorksheetFunction.CountIf(Range(Cells(r.Row, "C"), Cells(r1.Row, "C")), r1.Offset(-1, -1))
If j = k Then
Cells(r1.Row - 1, "C").EntireRow.Interior.ColorIndex = 3
End If
Loop
End Sub

 

[1kat]

Sorry for the late reply. Trying this today and will let you know. Thanks!

 

[1kat]

When I run this macro on my data nothing happens.

 

[venkat1926]

I have modified the macro now try

Sub test()
Dim r As Range, r1 As Range, add As String
Dim j As Integer, k As Integer
Set r = Range("D1")
Set r1 = Columns("D:D").Cells.Find(what:="count", lookat:=xlPart)
add = r1.Address
j = WorksheetFunction.CountA(Range(Cells(r.Row + 1, "C"), Cells(r1.Row - 1, "C")))
k = WorksheetFunction.CountIf(Range(Cells(r.Row + 1, "C"), Cells(r1.Row - 1, "C")), r1.Offset(-1, -1))
If j = k Then
'Cells(r1.Row, "C").EntireRow.ColorIndex = 3
Range(Cells(r.Row + 1, "C"), Cells(r1.Row - 1, "C")).Interior.ColorIndex = 3

End If
Do
Set r = r1
Set r1 = Cells.FindNext(r1)
If r1 Is Nothing Then Exit Do
If r1.Address = add Then Exit Do
j = WorksheetFunction.CountA(Range(Cells(r.Row + 1, "C"), Cells(r1.Row - 1, "C")))
k = WorksheetFunction.CountIf(Range(Cells(r.Row + 1, "C"), Cells(r1.Row - 1, "C")), r1.Offset(-1, -1))
If j = k Then
'Cells(r1.Row - 1, "C").EntireRow.Interior.ColorIndex = 3
Range(Cells(r.Row + 1, "C"), Cells(r1.Row - 1, "C")).Interior.ColorIndex = 3
End If
Loop
End Sub

Sub undo()

ActiveSheet.Cells.Interior.ColorIndex = xlNone
End Sub