Need cell color via Macro

[sksanjeev786]

Hi Team,

Need support on Macro

I have the Main data from (A14 to I25) and
1. From A30 to I39 where ever we got an "X" letter i need a "GREEN" color on (A14 to I25)
2. From A43 to I51 whatever letter we have should match with Row 14 and need RED color on (A14 to I25)

INPUT :

Diversity Calculations - February 2023_KGDC.xlsm
	A	B	C	D	E	F	G	H	I
14		A	B	C	D	E	F	G	H
15	TOP 2 BOX (NET)	49%	50%	42%	52%	42%	61%	39%	53%
16	(5) Agree strongly	19%	18%	19%	18%	15%	23%	16%	15%
17	(4) Agree somewhat	30%	32%	23%	34%	27%	37%	23%	38%
18	(3) Neither agree nor disagree	35%	35%	37%	26%	37%	28%	37%	28%
19	BOTTOM 2 BOX (NET)	16%	15%	21%	22%	21%	12%	25%	18%
20	(2) Disagree somewhat	10%	7%	13%	15%	11%	7%	13%	10%
21	(1) Disagree strongly	6%	7%	7%	7%	11%	5%	11%	8%
22	Sigma	100%	100%	100%	100%	100%	100%	100%	100%
23	Mean	347%	347%	333%	341%	325%	367%	319%	342%
24	S.D.	110%	110%	114%	116%	116%	106%	119%	112%
25	S.E.	9%	9%	9%	10%	9%	9%	10%	10%
26
27
28	Q. The People In The Ad (1)	65	66	67	68	69	70	71	72
29
30	TOP 2 BOX (NET)	49	50	42	52	42	61 X	39	53
31	(5) Agree strongly	19	18	19	18	15	23	16	15
32	(4) Agree somewhat	30	32	23	34	27	37	23	38
33	(3) Neither agree nor disagree	35	35	37	26	37	28	37	28
34	BOTTOM 2 BOX (NET)	16	15	21 X	22 X	21 X	12	25 X	18
35	(2) Disagree somewhat	10	7	13	15 X	11	7	13	10
36	(1) Disagree strongly	6	7	7	7	11 X	5	11 X	8
37	Base	(150)	(137)	(150)	(137)	(150)	(137)	(150)	(137)
38	Mean	3.47	3.47	3.33	3.41	3.25	3.67 X	3.19	3.42
39	S.E.	0.09	0.09	0.09	0.10	0.09	0.09	0.10	0.10
40
41
42	TOP 2 BOX (NET)	48 GQ	48 GQ	48 GQ	48 GQ	48 GQ	48 GQ	48 GQ	48 GQ
43	(5) Agree strongly	18 QT	18 QT	18 QT	18 QT	18 QT	18 QT	18 QT	18 QT
44	(4) Agree somewhat	31 CG	31 CG	31 CG	31 CG	31 CG	31 CG	31 CG	31 CG
45	(3) Neither agree nor disagree	37 DFH	37 DFH	37 DFH	37 DFH	37 DFH	37 DFH	37 DFH	37 DFH
46	BOTTOM 2 BOX (NET)	15	15	15	15	15	15	15	15
47	(2) Disagree somewhat	9	9	9	9	9	9	9	9
48	(1) Disagree strongly	6	6	6	6	6	6	6	6
49	Base
50	Mean	3.45 EGQ	3.45 EGQ	3.45 EGQ	3.45 EGQ	3.45 EGQ	3.45 EGQ	3.45 EGQ	3.45 EGQ
51	S.E.	0.09	0.09	0.09	0.09	0.09	0.09	0.09	0.09
The People In The Ad

Cell Formulas
Range	Formula
B14:I14	B14	=CHAR(B28)

OUTPUT (Added color Manually)
Below is my output i have updated manually color on the cells:-

V1.xlsm
	A	B	C	D	E	F	G	H	I
15	TOP 2 BOX (NET)	49%	50%	42%	52%	42%	61%	39%	53%
16	(5) Agree strongly	19%	18%	19%	18%	15%	23%	16%	15%
17	(4) Agree somewhat	30%	32%	23%	34%	27%	37%	23%	38%
18	(3) Neither agree nor disagree	35%	35%	37%	26%	37%	28%	37%	28%
19	BOTTOM 2 BOX (NET)	16%	15%	21%	22%	21%	12%	25%	18%
20	(2) Disagree somewhat	10%	7%	13%	15%	11%	7%	13%	10%
21	(1) Disagree strongly	6%	7%	7%	7%	11%	5%	11%	8%
22	Sigma	100%	100%	100%	100%	100%	100%	100%	100%
23	Mean	347%	347%	333%	341%	325%	367%	319%	342%
24	S.D.	110%	110%	114%	116%	116%	106%	119%	112%
25	S.E.	9%	9%	9%	10%	9%	9%	10%	10%
The People In The Ad

 

[DanteAmor]

Try this:

Sub cell_color()
  Dim i As Long, j As Long
 
  For i = 30 To 39
    For j = 2 To 9
      If InStr(1, Cells(i, j).Value, "X") > 0 Then
        Cells(i - 15, j).Interior.Color = 4697456     'or vbgreen
      End If
    Next
  Next
 
  For i = 42 To 51
    For j = 2 To 9
      If InStr(1, Cells(i, j).Value, Cells(14, j)) > 0 Then
        Cells(i - 27, j).Interior.Color = 5263615   'or vbRed
      End If
    Next
  Next
End Sub

The same macro but compacted.

Sub cell_color()
  Dim i As Long, j As Long, m As Long
  Dim s As String, n
  
  For j = 2 To 9
    For i = 30 To 51
      Select Case i
        Case 30 To 40: s = "X":          m = 15: n = 4697456  'or vbgreen
        Case 42 To 51: s = Cells(14, j): m = 27: n = 5263615  'or vbRed
      End Select
      If InStr(1, Cells(i, j).Value, s) > 0 Then Cells(i - m, j).Interior.Color = n
    Next
  Next
End Sub

 

[DanteAmor]

With conditional formatting:

Dante Amor
	A	B	C	D	E	F	G	H	I
14		A	B	C	D	E	F	G	H
15	TOP 2 BOX (NET)	0.49	0.5	0.42	0.52	0.42	0.61	0.39	0.53
16	(5) Agree strongly	0.19	0.18	0.19	0.18	0.15	0.23	0.16	0.15
17	(4) Agree somewhat	0.3	0.32	0.23	0.34	0.27	0.37	0.23	0.38
18	(3) Neither agree nor disagree	0.35	0.35	0.37	0.26	0.37	0.28	0.37	0.28
19	BOTTOM 2 BOX (NET)	0.16	0.15	0.21	0.22	0.21	0.12	0.25	0.18
20	(2) Disagree somewhat	0.1	0.07	0.13	0.15	0.11	0.07	0.13	0.1
21	(1) Disagree strongly	0.06	0.07	0.07	0.07	0.11	0.05	0.11	0.08
22	Sigma	1	1	1	1	1	1	1	1
23	Mean	3.47	3.47	3.33	3.41	3.25	3.67	3.19	3.42
24	S.D.	1.1	1.1	1.14	1.16	1.16	1.06	1.19	1.12
25	S.E.	0.09	0.09	0.09	0.1	0.09	0.09	0.1	0.1
The People In The Ad

Cell Formulas
Range	Formula
B14:I14	B14	=CHAR(B28)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
B15:I25	Expression	=SEARCH(B$14,B42)	text	NO
B15:I25	Expression	=SEARCH("X",B30)	text	NO

 

[sksanjeev786]

Thank you so much, DanteAmor

It really saves a lot of time.

 

[sksanjeev786]

Try this:

Sub cell_color()
  Dim i As Long, j As Long
 
  For i = 30 To 39
    For j = 2 To 9
      If InStr(1, Cells(i, j).Value, "X") > 0 Then
        Cells(i - 15, j).Interior.Color = 4697456     'or vbgreen
      End If
    Next
  Next
 
  For i = 42 To 51
    For j = 2 To 9
      If InStr(1, Cells(i, j).Value, Cells(14, j)) > 0 Then
        Cells(i - 27, j).Interior.Color = 5263615   'or vbRed
      End If
    Next
  Next
End Sub

The same macro but compacted.

Sub cell_color()
  Dim i As Long, j As Long, m As Long
  Dim s As String, n
 
  For j = 2 To 9
    For i = 30 To 51
      Select Case i
        Case 30 To 40: s = "X":          m = 15: n = 4697456  'or vbgreen
        Case 42 To 51: s = Cells(14, j): m = 27: n = 5263615  'or vbRed
      End Select
      If InStr(1, Cells(i, j).Value, s) > 0 Then Cells(i - m, j).Interior.Color = n
    Next
  Next
End Sub

Hi Sir,

I was trying with the below MACRO and was not able to get Red Color but only Green Cells appeared with the below MAcro

I know I am missing something in the below line can you please help me on this

"
ElseIf InStr(1, Cells(x + 28, 132), Cells(1, y)) Then
'Change the text color
ActiveCell.Interior.Color = RedColor
"

MACRO

Sub changeTextColor()
GreenColor = RGB(0, 176, 80)
RedColor = RGB(192, 0, 0)
BlackColor = RGB(0, 0, 0)


'Select cell

Range("B15:EC25").HorizontalAlignment = xlCenter
Range("B15:EC25").VerticalAlignment = xlCenter
Range("B15:EC25").Select

'Loop the cells
For x = 15 To 25
For y = 2 To 132
Cells(x, y).Select
If InStr(1, ActiveCell.Offset(15, 0), "X") Then
'Change the text color
ActiveCell.Interior.Color = GreenColor
ElseIf InStr(1, Cells(x + 28, 132), Cells(1, y)) Then
'Change the text color
ActiveCell.Interior.Color = RedColor
Else
ActiveCell.Font.Color = BlackColor
End If
Next y
Next x

End Sub

 

[DanteAmor]

Cells(x + 28, 132), Cells(1, y)

According to your example from the initial post the numbers should be:

Cells(x + 27, y), Cells(14, y)

Then try:

Sub changeTextColor()
  Dim GreenColor As Long, RedColor As Long, BlackColor As Long
  Dim x As Long, y As Long
  
  GreenColor = RGB(0, 176, 80)
  RedColor = RGB(192, 0, 0)
  BlackColor = RGB(0, 0, 0)
  
  'Select cell
  With Range("B15:EC25")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Interior.ColorIndex = xlNone
    .Font.ColorIndex = xlNone
  End With
  
  'Loop the cells
  For x = 15 To 25
    For y = 2 To 132
      If InStr(1, Cells(x + 15, y), "X") Then
        Cells(x, y).Interior.Color = GreenColor   'Change the text color
      ElseIf InStr(1, Cells(x + 27, y), Cells(14, y)) Then
        Cells(x, y).Interior.Color = RedColor     'Change the text color
      Else
        Cells(x, y).Font.Color = BlackColor
      End If
    Next y
  Next x
End Sub

 

[sksanjeev786]

According to your example from the initial post the numbers should be:

Cells(x + 27, y), Cells(14, y)

Then try:

Sub changeTextColor()
  Dim GreenColor As Long, RedColor As Long, BlackColor As Long
  Dim x As Long, y As Long
 
  GreenColor = RGB(0, 176, 80)
  RedColor = RGB(192, 0, 0)
  BlackColor = RGB(0, 0, 0)
 
  'Select cell
  With Range("B15:EC25")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Interior.ColorIndex = xlNone
    .Font.ColorIndex = xlNone
  End With
 
  'Loop the cells
  For x = 15 To 25
    For y = 2 To 132
      If InStr(1, Cells(x + 15, y), "X") Then
        Cells(x, y).Interior.Color = GreenColor   'Change the text color
      ElseIf InStr(1, Cells(x + 27, y), Cells(14, y)) Then
        Cells(x, y).Interior.Color = RedColor     'Change the text color
      Else
        Cells(x, y).Font.Color = BlackColor
      End If
    Next y
  Next x
End Sub

Awesome! thank you so much Sir, for your time on this