Return multiple column headers based on the color of the cells within a row

Question

My data sheet ("srData") is a pivot table that is filled using a userform. All data have a unique ID in column A of the data sheet. In the userform checkboxes are selected, which will change the cells, in columns K:AA, interior color to white(2), else interior color is grey(15)

What I need to be able to do, is on another sheet ("Formulier"), based on the value of a drop down box (C6)where the unique ID is selected (ie SR-1, SR-2,SR-3 etc...), perform a lookup against the table to return the headers where the interior color of the Cell is colorindex=2. The results of this lookup need to be place on sheet("Formulier") in column A starting from row 19 down to row 28. No more then 10 rows will be filled based on the checkboxes.

For example, based on the table above, If SR-2 was selected from the drop down then the headers returned should be placed in column A, row 19= pH, row 20= NO2-IC

And if SR-4 is selected from drop down then the headers returned should be placed in column A, row 19= OBD, row 20= F-CFA, row 21=NO3-CFA, row 22= NO2-CFA

I have tried the code using this post but this is not exactly what I am looking for. As this code places the headers allin on cell, and it is based on a value and not a color.

I hope someone is able to help me.

Answer 1

Color Search

In a Standard Module (Go to VBE >> Insert >> Module)

Option Explicit

Public Const CriteriaCell As String = "C6"    ' Criteria Cell Range Address

Sub ColorSearch()

    ' Source
    Const cSource As Variant = "srData"       ' Worksheet Name/Index
    Const cCriteriaColumn As Variant = "A"    ' Criteria Column Letter/Number
    Const cColumns As String = "K:AA"         ' Columns Range Address
    Const cHeaderRow As Long = 1              ' Header Row Number
    Const cColorIndex As Long = 2             ' Criteria Color Index (2-White)
    ' Target
    Const cTarget As Variant = "Formulier"    ' Worksheet Name/Index
    Const cFr As Long = 19                    ' First Row Number
    Const cCol As Variant = "A"               ' Column Letter/Number

    Dim rng As Range      ' Source Found Cell Range
    Dim vntH As Variant   ' Header Array
    Dim vntC As Variant   ' Color Array
    Dim vntT As Variant   ' Target Array
    Dim i As Long         ' Source/Color Array Column Counter
    Dim k As Long         ' Target Array Row Counter
    Dim sRow As Long      ' Color Row
    Dim SVal As String    ' Search Value
    Dim Noe As Long       ' Source Number of Elements

    ' Write value from Criteria Cell Range to Search Value.
    SVal = ThisWorkbook.Worksheets(cTarget).Range(CriteriaCell)

    ' In Source Worksheet
    With ThisWorkbook.Worksheets(cSource)
        ' Search for Search Value in Source Criteria Column and create
        ' a reference to Source Found Cell Range.
        Set rng = .Columns(cCriteriaColumn) _
                .Find(SVal, , xlValues, xlWhole, , xlNext)
        ' Check if Search Value not found. Exit if.
        If rng Is Nothing Then Exit Sub
        ' Write row of Source Found Cell Range to Color Row.
        sRow = rng.Row
        ' Release rng variable (not needed anymore).
        Set rng = Nothing
        ' In Source Columns
        With .Columns(cColumns)
            ' Copy Header Range to Header Array.
            vntH = .Rows(cHeaderRow)
            ' Copy Color Range to Color Array.
            vntC = .Rows(sRow)
            ' Write number of columns in Source Columns to Source Number
            ' of Elements.
            Noe = .Columns.Count
            ' Loop through columns of Color Range/Array.
            For i = 1 To Noe
                ' Write current ColorIndex of Color Range to current
                ' element in Color Array.
                vntC(1, i) = .Cells(sRow, i).Interior.ColorIndex
            Next
        End With
    End With
    ' Resize Target Array to Number of Elements rows and one column.
    ReDim vntT(1 To Noe, 1 To 1)
    ' Loop through columns of Color Array.
    For i = 1 To Noe
        ' Check if current value in Color Array is equal to Criteria
        ' Column Index.
        If vntC(1, i) = cColorIndex Then
            ' Count row in Target Array.
            k = k + 1
            ' Write value of current COLUMN in Header Array to
            ' element in current ROW of Target Array.
            vntT(k, 1) = vntH(1, i)
        End If
    Next

    ' Erase Header and Color Arrays (not needed anymore).
    Erase vntH
    Erase vntC

    ' In Target Worksheet
    With ThisWorkbook.Worksheets(cTarget)
        ' Calculate Target Range by resizing the cell at the intersection of
        ' Target First Row and Target Column, by Number of Elements.
        ' Copy Target Array to Target Range.
        .Cells(cFr, cCol).Resize(Noe) = vntT
    End With

End Sub

In Worksheet Formulier (In VBE double-click Formulier)

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Range(CriteriaCell)) Is Nothing Then
            ColorSearch
        End If
    End If
End Sub

White Cell Values Version

• Added writing the values of white cells to D column of worksheet Formulier .
• *** indicates what had to be added.
• Change ColorSearch2 to ColorSearch .

Sub ColorSearch2()

    ' Source
    Const cSource As Variant = "srData"       ' Worksheet Name/Index
    Const cCriteriaColumn As Variant = "A"    ' Criteria Column Letter/Number
    Const cColumns As String = "K:AA"         ' Columns Range Address
    Const cHeaderRow As Long = 1              ' Header Row Number
    Const cColorIndex As Long = 2             ' Criteria Color Index (2-White)
    ' Target
    Const cTarget As Variant = "Formulier"    ' Worksheet Name/Index
    Const cFr As Long = 19                    ' First Row Number
    Const cCol As Variant = "A"               ' Column Letter/Number
    Const cColVal As Variant = "D"            ' *** Value Column Letter/Number

    Dim rng As Range      ' Source Found Cell Range
    Dim vntH As Variant   ' Header Array
    Dim vntC As Variant   ' Color Array
    Dim vntV As Variant   ' *** Value Array
    Dim vntT As Variant   ' Target Array
    Dim vntTV As Variant  ' *** Target Value Array
    Dim i As Long         ' Source/Color Array Column Counter
    Dim k As Long         ' Target Array Row Counter
    Dim sRow As Long      ' Color Row
    Dim SVal As String    ' Search Value
    Dim Noe As Long       ' Source Number of Elements

    ' Write value from Criteria Cell Range to Search Value.
    SVal = ThisWorkbook.Worksheets(cTarget).Range(CriteriaCell)

    ' In Source Worksheet
    With ThisWorkbook.Worksheets(cSource)
        ' Search for Search Value in Source Criteria Column and create
        ' a reference to Source Found Cell Range.
        Set rng = .Columns(cCriteriaColumn) _
                .Find(SVal, , xlValues, xlWhole, , xlNext)
        ' Check if Search Value not found. Exit if.
        If rng Is Nothing Then Exit Sub
        ' Write row of Source Found Cell Range to Color Row.
        sRow = rng.Row
        ' Release rng variable (not needed anymore).
        Set rng = Nothing
        ' In Source Columns
        With .Columns(cColumns)
            ' Copy Header Range to Header Array.
            vntH = .Rows(cHeaderRow)
            ' Copy Color Range to Color Array.
            vntC = .Rows(sRow)
            ' *** Copy Color Range to Value Array.
            ' Note: The values are also written to Color Array, but are
            '       later overwritten with the Color Indexes.
            vntV = .Rows(sRow)
            ' Write number of columns in Source Columns to Source Number
            ' of Elements.
            Noe = .Columns.Count
            ' Loop through columns of Color Range/Array.
            For i = 1 To Noe
                ' Write current ColorIndex of Color Range to current
                ' element in Color Array.
                vntC(1, i) = .Cells(sRow, i).Interior.ColorIndex
            Next
        End With
    End With
    ' Resize Target Array to Number of Elements rows and one column.
    ReDim vntT(1 To Noe, 1 To 1)
    ' *** Resize Target Value Array to Number of Elements rows and one column.
    ReDim vntTV(1 To Noe, 1 To 1)
    ' Loop through columns of Color Array.
    For i = 1 To Noe
        ' Check if current value in Color Array is equal to Criteria
        ' Column Index.
        If vntC(1, i) = cColorIndex Then
            ' Count row in Target Array.
            k = k + 1
            ' Write value of current COLUMN in Header Array to
            ' element in current ROW of Target Array.
            vntT(k, 1) = vntH(1, i)
            ' *** Write value of current COLUMN in Value Array to
            ' element in current ROW of Target Value Array.
            vntTV(k, 1) = vntV(1, i)
        End If
    Next

    ' Erase Header and Color Arrays (not needed anymore).
    Erase vntH
    Erase vntC
    Erase vntV '***

    ' In Target Worksheet
    With ThisWorkbook.Worksheets(cTarget)
        ' Calculate Target Range by resizing the cell at the intersection of
        ' Target First Row and Target Column, by Number of Elements.
        ' Copy Target Array to Target Range.
        .Cells(cFr, cCol).Resize(Noe) = vntT
        ' *** Calculate Target Value Range by resizing the cell at the
        ' intersection of Target First Row and Value Column, by Number of
        ' Elements.
        ' Copy Target Value Array to Target Value Range.
        .Cells(cFr, cColVal).Resize(Noe) = vntTV
    End With

End Sub