Excel VBA - Return Colum header value

Question

Hello All,

i have a table in which macro searches for cells that are conditionally formatted RED . Looking for a piece of code which will return the first column header of cell if cell is formatted RED.

*red indicates the cell color is conditionally formatted RED

the macro searches for first RED cell in range C2-H2 and stops when it encounters first red cell then iterates to C3-H3

i am looking for an output like the below table. the code should return the first red cell only in a row

Plant	Part Number	Red On
a	Part1	Past Due
a	Part2	1-1-2024

and the list goes on

Answer 1

Sub Test()
Dim Where As Range, WhereRow As Range, R As Range
Dim C As New Collection
Dim Data, Item
Dim i As Long, j As Long

'Parse the cells
Set Where = Range("A1").CurrentRegion
C.Add Array(Range("A1"), Range("B1"), "Red On")
For Each WhereRow In Where.Rows
For Each R In WhereRow.Cells
If R.DisplayFormat.Interior.Color = vbRed Then
C.Add Array(Range("A" & R.Row), Range("B" & R.Row), Cells(1, R.Column))
Exit For
End If
Next
Next
If C.Count = 0 Then
MsgBox "No Items found"
Exit Sub
End If
'Compile the output
ReDim Data(1 To C.Count, 1 To 3)
For Each Item In C
i = i + 1
For j = 1 To 3
Data(i, j) = Item(j - 1)
Next
Next
'Flush into a new sheet
Worksheets.Add
Range("A1").Resize(UBound(Data), UBound(Data, 2)).Value = Data
End Sub

Answer 2

Hi @Andreas Killer. many thanks for your code it worked but i missed one piece in my initial post . I have re-edited it. Currently its returning all the red cells in the range . i wanted only fist red cell . can you please modify

Answer 3

Sub Test()
Dim Where As Range, R As Range
Dim C As New Collection
Dim Data, Item
Dim i As Long, j As Long

'Parse the cells
Set Where = Range("A1").CurrentRegion
C.Add Array(Range("A1"), Range("B1"), "Red On")
For Each R In Where
If R.DisplayFormat.Interior.Color = vbRed Then
C.Add Array(Range("A" & R.Row), Range("B" & R.Row), Cells(1, R.Column))
End If
Next
If C.Count = 0 Then
MsgBox "No Items found"
Exit Sub
End If
'Compile the output
ReDim Data(1 To C.Count, 1 To 3)
For Each Item In C
i = i + 1
For j = 1 To 3
Data(i, j) = Item(j - 1)
Next
Next
'Flush into a new sheet
Worksheets.Add
Range("A1").Resize(UBound(Data), UBound(Data, 2)).Value = Data
End Sub

Answer 4

Sir i do not have option to attach the file. Disabled by my organization. it basically looks something like this.

Current code checks red cell in row range C2-H2 .i want something that will return header of the cell where it found red and return table like this in new sheet

Plant	Part Number	Red On
a	Part1	Past due
a	Part2	1-14-2024

Answer 5

We need to see your (sample) file.
Why a sample file is important for troubleshooting. How to do it. - Microsoft Community

Andreas.