Find header group in the whole column data, and fill colours

[Kishan]

Using Excel 2000

Hi,

I want VBA, which look in to whole Column (C:P) data; header group is in the row 2, 3, and 4 through (C:P) and fill colour if matches finds

For example...
Column C header C1:C3 = ABC look in to whole column C, ABC, and fill colour
Column D header D1:D3 = ABD look in to whole column D, ABD, and fill colour
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
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			D	B	B	A	D	B	C	A	D	C	B	B	C	A
8			D	C	C	A	D	C	B	A	D	B	C	C	B	A
9			D	A	A	B	D	A	D	A	C	D	B	A	C	A
10			C	B	A	D	C	A	D	A	A	D	D	B	A	A
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

 

[mrshl9898]

Like this?

Sub colorcells()

Dim rownum As Long
Dim rownum2 As Long
Dim colnum As Long


colnum = 3
Do Until colnum = 17


rownum = 1
rownum2 = 6
Do Until rownum2 = 49


color1 = Cells(rownum, colnum).Interior.Color
If Cells(rownum2, colnum).Value = Cells(rownum, colnum) And Cells(rownum2 + 1, colnum) = Cells(rownum + 1, colnum) And Cells(rownum2 + 2, colnum) = Cells(rownum + 2, colnum) Then
Cells(rownum2, colnum).Interior.Color = color1
Cells(rownum2 + 1, colnum).Interior.Color = color1
Cells(rownum2 + 2, colnum).Interior.Color = color1
End If


rownum2 = rownum2 + 1
Loop


colnum = colnum + 1
Loop


End Sub

*just realised this won't deal with the likes of AAA in a AAAA scenario... Looking again

 

[mrshl9898]

This seems to be working:

Sub colorcells()

Dim rownum As Long
Dim rownum2 As Long
Dim colnum As Long


colnum = 3
Do Until colnum = 17


rownum = 1
rownum2 = 6
Do Until rownum2 = 49


color1 = Cells(rownum, colnum).Interior.Color
If Cells(rownum2, colnum).Value = Cells(rownum, colnum) And Cells(rownum2 + 1, colnum) = Cells(rownum + 1, colnum) And Cells(rownum2 + 2, colnum) = Cells(rownum + 2, colnum) Then
Cells(rownum2, colnum).Interior.Color = color1
Cells(rownum2 + 1, colnum).Interior.Color = color1
Cells(rownum2 + 2, colnum).Interior.Color = color1
rownum2 = rownum2 + 2
End If


rownum2 = rownum2 + 1
Loop


colnum = colnum + 1
Loop


End Sub

 

[Marcelo Branco]

Maybe...

Assumes that cells in the range C2:P4 are already colored

Sub aTest()
    Dim rCrit As Range, rData As Range
    Dim i As Long, j As Long
    
    Set rCrit = Range("C2:P4")
    Set rData = Range("C7:P" & Cells(Rows.Count, "C").End(xlUp).Row)
    
    For i = 1 To rData.Columns.Count
        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
                    j = j + 3
                Else
                    j = j + 1
                End If
            Loop Until j > rData.Rows.Count - 2
        End With
    Next i
End Sub

M.

 

[Kishan]

This seems to be working:

Hi mrshl9898, thank you for the help I tried but do not get any cell highlighted

Regards,
Kishan

 

[Kishan]

Maybe...

Assumes that cells in the range C2:P4 are already colored

Sub aTest()
    Dim rCrit As Range, rData As Range
    Dim i As Long, j As Long
    
    Set rCrit = Range("C2:P4")
    Set rData = Range("C7:P" & Cells(Rows.Count, "C").End(xlUp).Row)
    
    For i = 1 To rData.Columns.Count
        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
                    j = j + 3
                Else
                    j = j + 1
                End If
            Loop Until j > rData.Rows.Count - 2
        End With
    Next i
End Sub

M.

Hi Marcelo Branco, I like your way of colouring, VBA-Solution!! It is very practical, excellent idea!!

I tried by changing the range C2:P4, with different colours and it is resulting spot on!!

Thank you very much for your time and help

Regards,
Kishan

 

[Marcelo Branco]

You are welcome. Thanks for the feedback.

M.