Вернуть несколько заголовков столбцов на основе цвета ячеек в строке

Question

Моя таблица данных ("srData") - это сводная таблица, которая заполняется с использованием пользовательской формы. Все данные имеют уникальный идентификатор в столбце A таблицы данных. В пользовательской форме установлены флажки, которые изменят ячейки, в столбцах K: AA, цвет салона на белый (2), иначе цвет салона серый (15)

То, что мне нужно сделать, это на другом листе («Formulier»), основываясь на значении выпадающего списка (C6), где выбран уникальный идентификатор (т. Е. SR-1, SR-2, SR-3 и т. Д.), Выполните поиск по таблице, чтобы получить заголовки, в которых внутренний цвет ячейки имеет colorindex = 2. Результаты этого поиска должны быть размещены на листе («Formulier») в столбце A, начиная со строки 19 и заканчивая строкой 28. На основе флажков будет заполнено не более 10 строк.

Например, на основании приведенной выше таблицы, если в раскрывающемся списке был выбран SR-2, возвращаемые заголовки должны быть помещены в столбец A, строка 19 = pH, строка 20 = NO2-IC.

И если SR-4 выбран из выпадающего списка, возвращаемые заголовки должны быть помещены в столбец A, строка 19 = OBD, строка 20 = F-CFA, строка 21 = NO3-CFA, строка 22 = NO2-CFA

Я пробовал код, используя этот пост , но это не совсем то, что я ищу. Поскольку этот код размещает заголовки в ячейке, он основан на значении, а не на цвете.

Надеюсь, кто-нибудь сможет мне помочь.

Answer 1

Поиск цвета

в стандартном модуле (Перейти к VBE >> Вставить >> Модуль)

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

В формуле листа (в VBE двойной щелчок по формуле)

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

Версия значений белых ячеек

• Добавлена ​​запись значений белых ячеек в столбец D на рабочем листе Formulier.
• *** указывает, что нужно было добавить.
• Изменить ColorSearch2 на 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