Show Values of Only Cells that are Highlighted?

[slam]

Hi lovely people! Hope everyone is doing well today.

I have a list of Project Names in A2:A100. In D2:BC100 there is a value of either Y or N. Some of the N cells are highlighted red and some of the Y cells are highlight yellow based on conditional formatting, but for this purpose, I only care about cells that are both N and red.

I want to create a summary of this worksheet that is easier to read. Essentially, I want to list only the projects that have at least one red N on their row, and then only list the value from the column header (row 1) for where there's a red N.

Here is a mock up of how it currently looks:

Example.xlsx
	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	AH	AI	AJ	AK	AL	AM	AN	AO	AP	AQ	AR	AS	AT	AU	AV	AW	AX	AY	AZ	BA	BB	BC
1	Project	Country	City	1	2	3	4	5	6	7	8	9	10	11	12	13	14	15	16	17	18	19	20	21	22	23	24	25	26	27	28	29	30	31	32	33	34	35	36	37	38	39	40	41	42	43	44	45	46	47	48	49	50	51	52
2	Project 1			N	N	N	N	N	N	N	N	Y	Y	Y	Y	N	N	N	N	Y	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	Y	Y	N	N	Y	Y
3	Project 2			N	N	N	N	Y	N	N	N	N	Y	N	N	N	N	N	N	N	N	N	N	N	N	Y	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	Y	N	N	Y	Y
4	Project 3			N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	Y	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N
5	Project 4			N	N	N	N	N	N	N	N	Y	Y	Y	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	Y	N
6	Project 5			N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N	N
Mock-Up

This is what I'm trying to achieve:

Example.xlsx
	A	B	C	D	E
1	Project 1	18	27	29	33
2	Project 2	6	24
3	Project 3	18
4	Project 4	12	52
Sheet5

Is this possible, or is the conditional formatting a roadblock (vs normal highlighting?)

Using Office 365 ProPlus, and happy to use VBA as a solution if needed.

Thank you!

 

[slam]

-4105 when I point it to M14, but again, I don't have any red font; I only have red fill, which is what M14 is (via conditional formatting)

 

[Marcelo Branco]

Oh you have red fill only...

Tell me what this returns

Sub GetColorIndex()
    MsgBox Range("M14").DisplayFormat.Interior.ColorIndex
End Sub

M.

 

[slam]

That returns 3

 

[Marcelo Branco]

Change 2 code lines to
'Get the ColorIndex used in CF
lMyColorIndex = 3

and below

If rRow.Cells(1, i).DisplayFormat.Interior.ColorIndex = lMyColorIndex Then
dic(rValues.Cells(1, i).Value) = ""
End If


M.

 

[slam]

Now getting a 1004 error on this line:

wsResult.Range("B" & j).Resize(1, dic.Count) = dic.keys

Here's my full code:

Sub aTest()
    Dim dic As Object, rData As Range
    Dim rRow As Range, i As Long, j As Long, rValues As Range
    Dim lMyColorIndex As Long, sProject As String
    Dim wsData As Worksheet, wsResult As Worksheet
 
    Set wsData = ThisWorkbook.Sheets("Orders per Company Code") 'assumnes data in sheet1
    Set wsResult = ThisWorkbook.Sheets("Summary") 'assumes there is a sheet named Sheet2
 
    j = 1
    With wsData
        'Get the ColorIndex used in CF
        lMyColorIndex = 3
     
        Set rData = .Range("A2:BC100") '<--adjust the range
        Set rValues = .Range("A1:BC1") '<--adjust the range
     
        For Each rRow In rData.Rows
            sProject = rRow.Cells(1, 1)
            Set dic = CreateObject("Scripting.Dictionary")
            For i = 4 To 55 '<-- adjust 9 to your last column (56 if it's BD)
                If rRow.Cells(1, i).DisplayFormat.Interior.ColorIndex = lMyColorIndex Then
                    dic(rValues.Cells(1, i).Value) = ""
                End If
            Next i
         
            'Display Result in Sheet2
            j = j + 1
            wsResult.Range("A" & j) = sProject
            wsResult.Range("B" & j).Resize(1, dic.Count) = dic.keys
        Next rRow
    End With
     
End Sub

 

[Marcelo Branco]

Is there a project with no cells highlighted?
If so, replace the lines at the end of the code to ...

  'Display Result in Sheet2
            j = j + 1
            wsResult.Range("A" & j) = sProject
            If dic.Count > 0 Then wsResult.Range("B" & j).Resize(1, dic.Count) = dic.keys
        Next rRow

M.

 

[slam]

Hi Marcelo,

Thank you again. This mostly works now!

The only thing that's not quite right is it is showing all projects, even when there are no red cells. Is there a little tweak to only show the projects with at least 1 red cell?

Thank you so much for your help and patience!

 

[Marcelo Branco]

Yes

Change the last bit of code (see post 15 above) to

'Display Result in Sheet2
If dic.Count > 0 Then
    j = j + 1
    wsResult.Range("A" & j) = sProject
    wsResult.Range("B" & j).Resize(1, dic.Count) = dic.keys
End If

M.

 

[slam]

Perfect. Thank you so much Marcelo! You're a genius!

 

[Marcelo Branco]

Wow it worked

You're welcome

M.