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

 

[Eric W]

You can do this with just a formula - for example:

	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF
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
6
7	A	2	0	3	0	0	1	0	2	2	2	1	1	1	2
8	B	2	0	1	0	0	1	0	0	2	0	2	3	0	3
9	C	0	1	0	1	2	0	0	0	0	0	0	0	0	0
10	D	0	2	0	1	1	0	1	0	0	0	0	0	0	0

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet1​

Array Formulas Cell Formula S7 {=SUM(IF(C$7:C$45=S$2,IF(C$8:C$46=S$3,IF(C$9:C$47=S$4,IF(C$10:C$48=$R7,1)))))} <thead> </thead><tbody> </tbody> Entered with Ctrl+Shift+Enter. If entered correctly, Excel will surround with curly braces {}. Note: Do not try and enter the {} manually yourself

<tbody>
</tbody>

Put the array formula in S7, then copy to the rest of the table. It doesn't do the highlighting, but you can probably make Conditional Formatting work. (CF is far different in Excel 2000 to the current version.) There are ways to hide the zeros if you prefer to see empty cells instead of 0.

If you still want a macro, that should be easy enough, but this formula does point out a difference. In your column 5, you show a count of 1 for BCBC. The discrepancy seems to be in cells G25:G30. G25:G28 = BCBC, and G27:G30 = BCBC, it overlaps. How do you want to handle that?

 

[Kishan]

You can do this with just a formula - for example
Put the array formula in S7, then copy to the rest of the table. It doesn't do the highlighting, but you can probably make Conditional Formatting work. (CF is far different in Excel 2000 to the current version.) There are ways to hide the zeros if you prefer to see empty cells instead of 0.

Hi Eric, Thanks for your reply

If you still want a macro, that should be easy enough,

Really if it is not much trouble I would prefer to have macro solution

but this formula does point out a difference. In your column 5, you show a count of 1 for BCBC. The discrepancy seems to be in cells G25:G30. G25:G28 = BCBC, and G27:G30 = BCBC, it overlaps. How do you want to handle that?

I do not want handle overlaps if G25:G27 Is BCB & G28 = C so it's counted = 1, if G28:G30 would have been BCB & G31 would have been C, so it could have been correct count = 2

This you can observe in column A For "ABC" A15:A17 = ABC, A18:A20 = ABC, A21:A23 = ABC, are not over lapped

Have a nice time

Regards,
Kishan

 

[Eric W]

Consider:

Sub CountNColor()
Dim i As Long, r As Long, j As Long, ctrs(1 To 4, 1 To 1) As Variant, lr As Long, MyGray As Long, MyPink As Long

    Range("C:P").Interior.Color = xlNone
    Range("C5:P5").Interior.Color = vbGreen
    MyGray = RGB(100, 100, 100)
    MyPink = RGB(255, 153, 204)
    
    For i = 1 To 14
        lr = Cells(Rows.Count, i + 2).End(xlUp).Row
        Erase ctrs
        For r = 7 To lr - 2
            If Cells(r, i + 2) = Cells(2, i + 18) And _
               Cells(r + 1, i + 2) = Cells(3, i + 18) And _
               Cells(r + 2, i + 2) = Cells(4, i + 18) Then
               For j = 0 To 2
                    If Cells(r + j, i + 2).Interior.Color <> MyGray Then Cells(r + j, i + 2).Interior.Color = IIf(i Mod 2 = 1, vbYellow, MyPink)
               Next j
               For j = 1 To 4
                    If Cells(r + 3, i + 2) = Cells(6 + j, "R") Then
                        ctrs(j, 1) = ctrs(j, 1) + 1
                        Cells(r + 3, i + 2).Interior.Color = MyGray
                        r = r + 2
                        Exit For
                    End If
                Next j
            End If
        Next r
        Range(Cells(7, i + 18), Cells(10, i + 18)).Value = ctrs
    Next i
                
End Sub

The counts are different for column 12. It looks like you missed N24:N27.

 

[Kishan]

Consider:

Sub CountNColor()
Dim i As Long, r As Long, j As Long, ctrs(1 To 4, 1 To 1) As Variant, lr As Long, MyGray As Long, MyPink As Long

    Range("C:P").Interior.Color = xlNone
    Range("C5:P5").Interior.Color = vbGreen
    MyGray = RGB(100, 100, 100)
    MyPink = RGB(255, 153, 204)
    
    For i = 1 To 14
        lr = Cells(Rows.Count, i + 2).End(xlUp).Row
        Erase ctrs
        For r = 7 To lr - 2
            If Cells(r, i + 2) = Cells(2, i + 18) And _
               Cells(r + 1, i + 2) = Cells(3, i + 18) And _
               Cells(r + 2, i + 2) = Cells(4, i + 18) Then
               For j = 0 To 2
                    If Cells(r + j, i + 2).Interior.Color <> MyGray Then Cells(r + j, i + 2).Interior.Color = IIf(i Mod 2 = 1, vbYellow, MyPink)
               Next j
               For j = 1 To 4
                    If Cells(r + 3, i + 2) = Cells(6 + j, "R") Then
                        ctrs(j, 1) = ctrs(j, 1) + 1
                        Cells(r + 3, i + 2).Interior.Color = MyGray
                        r = r + 2
                        Exit For
                    End If
                Next j
            End If
        Next r
        Range(Cells(7, i + 18), Cells(10, i + 18)).Value = ctrs
    Next i
                
End Sub

The counts are different for column 12. It looks like you missed N24:N27.

Hi Eric, I like your VBA solution!! Good idea to have sky-blue colour in the background looks cool!!

Thank you very much for your time and help

Have a nice time

Regards,
Kishan

 

[MickG]

Try this:-
It should be close !!!!

[COLOR=navy]Sub[/COLOR] MG24Nov04
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, Ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] nStr [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] R [COLOR=navy]As[/COLOR] Range, nRng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] A, B, C, D
[COLOR=navy]Set[/COLOR] Rng = Range("C7", Range("C" & Rows.Count).End(xlUp))
Rng.Resize(, 14).Interior.ColorIndex = xlNone
Rng.Resize(, 14).Font.ColorIndex = 1
[COLOR=navy]Set[/COLOR] R = [a1]
[COLOR=navy]For[/COLOR] Ac = 0 To 13
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
        nStr = Join(Application.Transpose(Cells(2, 19).Resize(3).Offset(, Ac)), "")
            [COLOR=navy]If[/COLOR] Join(Application.Transpose(Dn.Offset(, Ac).Resize(3)), "") = nStr And Intersect(R, Dn.Resize(3)) [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                [COLOR=navy]Set[/COLOR] R = Dn.Offset(, Ac).Resize(3)
                Dn.Resize(3).Offset(, Ac).Interior.ColorIndex = IIf(Ac Mod 2 = 0, 6, 7)
                    [COLOR=navy]If[/COLOR] nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR] [COLOR=navy]Set[/COLOR] nRng = Dn.Offset(3, Ac) Else [COLOR=navy]Set[/COLOR] nRng = Union(nRng, Dn.Offset(3, Ac))
                        [COLOR=navy]Select[/COLOR] [COLOR=navy]Case[/COLOR] True
                            [COLOR=navy]Case[/COLOR] Dn.Offset(3, Ac) = "A": A = A + 1
                            [COLOR=navy]Case[/COLOR] Dn.Offset(3, Ac) = "B": B = B + 1
                            [COLOR=navy]Case[/COLOR] Dn.Offset(3, Ac) = "C": C = C + 1
                            [COLOR=navy]Case[/COLOR] Dn.Offset(3, Ac) = "D": D = D + 1
                        [COLOR=navy]End[/COLOR] Select
                    [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Dn
Cells(7, 19 + Ac).Value = IIf(A = 0, "", A): A = 0
Cells(8, 19 + Ac).Value = IIf(B = 0, "", B): B = 0
Cells(9, 19 + Ac).Value = IIf(C = 0, "", C): C = 0
Cells(10, 19 + Ac).Value = IIf(D = 0, "", D): D = 0
[COLOR=navy]Next[/COLOR] Ac
[COLOR=navy]With[/COLOR] nRng
    .Interior.ColorIndex = 16
    .Font.Color = vbWhite
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Sorry didn't realise you had received a VbA solution
Regards Mick

 

[Kishan]

Try this:-
It should be close !!!!
Sorry didn't realise you had received a VbA solution
Regards Mick

Hi MickG, Nevertheless having one more option

Code is finding overlapped occurrence result should be as shown below

Thanks for your reply

Book1
	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
6
7		A	2		3			1		2	1	1	1	1	1	2
8		B	2		1			1			1		1	3		1
9		C		1		1	1
10		D		2		1	1		1
11
Sheet2

Have a nice time

Regards,
Kishan

 

[Eric W]

I'm glad you like it!

When you said "sky-blue colour", I was scratching my head since I didn't intentionally put in a sky-blue colour. Then I realized that this line

Range("C:P").Interior.Color = xlNone

should have been

Range("C:P").Interior.Color = vbWhite

xlNone and vbWhite are built-in constants, but xlNone really doesn't apply to Interior.Color. It just happened to map to a sky blue. And normally I would have spotted that before posting my code, but in a odd coincidence, I keep the default background color for my windows at almost the exact same shade of blue. I find a lot of white to be hard on the eyes. So I didn't notice that the color was unexpected. But if you like it, then it works!

 

[Marcelo Branco]

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.

 

[Kishan]

I'm glad you like it!
xlNone and vbWhite are built-in constants, but xlNone really doesn't apply to Interior.Color. It just happened to map to a sky blue. And normally I would have spotted that before posting my code, but in a odd coincidence, I keep the default background color for my windows at almost the exact same shade of blue. I find a lot of white to be hard on the eyes. So I didn't notice that the color was unexpected. But if you like it, then it works!

Hi Eric, Thank you for the explanation even the colour is unexpected but I will use it with my other workbooks too. Because it is a very cool!! Shade.

Have a nice time

Regards,
Kishan