Complex count next to alphabets of header group in entire column data

[Kishan]

Using Excel 2000

Hi,

I have got 3-alphabets, 14-group is in the row 2, 3, and 4, columns S:AF

Note: Range S2:AF4, 3-alphabets is inserted manually and is not fixed so VBA should always consider the values are in range S2:AF4.

I want VBA, which counts (A, B, C and D occurrence) after the 3-alphabets groups, is find in the each columns through (C:P) and show counts results in range S7:AF10

And also highlights the cells in the column (C:P) as shown it is an optional if possible

For example...
Column "S" 3-alphabets in range S2:S4 = ABC, look ABC in to whole column "C" and count how many times has occurred after the "ABC" (A, B, C, and D) and the count of column "C" placed in to S7:S10

Column "T" 3-alphabets in range T2:T4 = ABD, look ABD in to whole column "D" and count how many times has occurred after the "ABD" (A, B, C, and D) and the count of column "C" placed in to T7:T10

Same procedure for the next columns up to column P

Sheet example...

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG
1
2																			A	A	C	A	B	D	B	A	A	A	A	C	B	A
3																			B	B	A	A	C	C	C	B	A	A	A	A	D	A
4																			C	D	A	B	B	A	B	C	A	A	A	A	C	A
5			1	2	3	4	5	6	7	8	9	10	11	12	13	14			1	2	3	4	5	6	7	8	9	10	11	12	13	14
6
7			D	B	B	A	D	B	C	A	D	C	B	B	C	A		A	2		3			1		2	1	1	1	1	1	2
8			D	C	C	A	D	C	B	A	D	B	C	C	B	A		B	2		1			1			1		1	2		1
9			D	A	A	B	D	A	D	A	C	D	B	A	C	A		C		1		1	1
10			C	B	A	D	C	A	D	A	A	D	D	B	A	A		D		2		1	1		1
11			B	D	B	D	B	B	C	A	B	C	C	C	A	B
12			D	C	C	D	C	C	A	B	C	A	B	A	B	C
13			C	B	B	D	A	B	A	C	A	B	C	A	D	A
14			A	C	C	D	B	D	B	A	B	D	A	B	D	B
15			A	B	B	C	C	C	C	A	D	C	A	D	D	C
16			B	C	D	B	A	B	B	B	D	A	A	C	D	B
17			C	A	D	C	B	C	D	C	C	A	B	A	D	C
18			A	A	C	A	C	B	C	A	A	B	D	B	C	A
19			B	A	A	B	B	C	A	A	A	D	C	C	B	B
20			C	A	A	C	D	A	B	B	A	D	B	A	D	D
21			A	A	A	B	D	A	C	D	A	D	C	A	D	C
22			B	A	B	C	C	B	A	C	A	D	A	A	C	B
23			C	A	C	A	A	D	A	A	B	C	B	B	B	C
24			B	A	A	B	A	C	B	A	C	B	C	C	C	B
25			C	A	A	C	B	A	C	A	A	C	A	A	A	C
26			B	A	A	A	C	B	A	A	B	B	A	A	B	A
27			C	B	B	B	B	D	A	B	C	C	A	B	C	A
28			A	C	C	D	C	D	B	D	B	B	A	D	A	B
29			A	A	A	D	B	C	D	C	D	C	B	C	B	D
30			A	A	A	D	C	A	C	B	C	A	D	A	C	D
31			A	A	A	D	A	A	A	C	A	A	C	A	A	C
32			A	B	A	C	B	A	A	B	B	B	A	B	B	A
33			B	D	A	A	D	A	B	D	C	D	B	C	D	A
34			C	D	A	B	C	A	C	C	A	C	D	A	D	A
35			B	C	A	C	B	B	A	B	B	A	C	B	D	A
36			C	B	B	B	C	C	B	D	C	A	B	C	D	B
37			B	C	C	C	A	A	C	C	A	B	D	B	D	D
38			D	B	A	A	B	B	A	A	A	D	D	C	C	C
39			D	C	B	A	D	C	B	B	B	D	D	A	A	B
40			C	A	C	B	D	A	D	D	C	D	C	B	B	C
41			B	B	B	C	C	B	C	C	A	C	B	D	C	A
42			D	D	D	A	B	C	B	A	A	B	C	D	B	A
43			D	D	C	B	D	A	D	A	A	C	A	C	D	A
44			D	D	A	D	C	A	C	A	B	A	B	A	C	B
45			C	C	B	C	A	B	A	A	C	A	C	B	A	C
46			A	A	C	A	B	D	B	A	A	A	A	C	B	A
47			B	B	A	A	C	C	C	B	A	A	A	A	D	A
48			C	D	A	B	B	A	B	C	A	A	A	A	C	A
49
Sheet1

Thank you in advance

Regards,
Kishan

 

[Kishan]

Is possible to adapt the code i provided in the thread
https://www.mrexcel.com/forum/excel...der-group-whole-column-data-fill-colours.html
to do the two tasks at once.

Try

Sub aTest()
    Dim rCrit As Range, rData As Range, rDest As Range
    Dim i As Long, j As Long, dic As Object, lGray As Long
    
    Set rCrit = Range("S2:AF4")
    Set rDest = Range("S7:AF10")
    Set rData = Range("C7:P" & Cells(Rows.Count, "C").End(xlUp).Row)
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    lGray = RGB(192, 192, 192)
    
    For i = 1 To rData.Columns.Count
        dic("A") = Empty: dic("B") = Empty: dic("C") = Empty: dic("D") = Empty
        With rData.Columns(i)
            j = 1
            Do
                If .Cells(j) = rCrit.Columns(i).Cells(1) _
                        And .Cells(j + 1) = rCrit.Columns(i).Cells(2) _
                        And .Cells(j + 2) = rCrit.Columns(i).Cells(3) Then
                    .Cells(j).Resize(3).Interior.Color = rCrit.Columns(i).Cells(1).Interior.Color
                    
                    If .Cells(j).Offset(-1).Interior.Color = rCrit.Columns(i).Cells(1).Interior.Color Then
                            .Cells(j).Interior.Color = lGray
                    End If
                    
                    If j < rData.Rows.Count - 3 Then
                        .Cells(j + 3).Interior.Color = lGray
                        dic(.Cells(j + 3).Value) = dic(.Cells(j + 3).Value) + 1
                    End If
                    j = j + 3
                Else
                    j = j + 1
                End If
            Loop Until j > rData.Rows.Count - 2
        End With
        rDest.Columns(i) = Application.Transpose(dic.items)
    Next i
End Sub

M.

Hi Marcelo Branco, I did liked your way of colouring macro as per header colour set-up which is very practical if one get bored watching the same colour can be replaced easily.

Thank you for adding a count feature in the previous macro and making it two in one solution. It is a very fine too.

Have a nice time

Regards,
Kishan