Excel 根据行中单元格的颜色返回多个列标题

我的数据表（“srData”）是一个使用用户表单填写的数据透视表。所有数据在数据表的a列中都有一个唯一的ID。 在用户表单中选中复选框，这将更改K:AA列中的单元格，内饰颜色为白色（2），否则内饰颜色为灰色（15）

我需要能够做的是，在另一张表（“Formulier”）上，根据选择唯一ID的下拉框（C6）的值（即SR-1、SR-2、SR-3等），对表格执行查找，以返回单元格内部颜色为colorindex=2的标题。此查找的结果需要放在A列的工作表（“Formulier”）上，从第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

我已经尝试了代码使用，但这并不完全是我要找的。因为这段代码将标题allin放在单元格上，它基于一个值而不是一种颜色

我希望有人能帮助我。

颜色搜索 在标准模块中（转到VBE>>插入>>模块） 在工作表Formulier中（在VBE中双击Formulier） 白单元格值版本

• 增加了将白色单元格的值写入工作表的D列

  Formulier

• ***指示必须添加的内容
• 将

  ColorSearch2

  更改为

  ColorSearch

Sub-ColorSearch2（）
"来源:
Const cSource As Variant=“srData”工作表名称/索引
Const ccriteria列作为Variant=“A”标准列字母/编号
Const cColumns As String=“K:AA”列范围地址
Const cHeaderRow长度=1'标题行编号
Const CCOLINDEX长度=2'标准颜色指数（2-白色）
"目标"
Const cTarget As Variant=“Formulier”工作表名称/索引
常量cFr长度=19'第一排编号
Const cCol As Variant=“A”列字母/编号
Const cColVal As Variant=“D”***值列字母/数字
Dim rng As Range“源找到单元格范围”
作为变体的Dim vntH头数组
Dim vntC作为“变体”颜色阵列
Dim vntV作为变量'***值数组
作为变型“目标阵列”的Dim vntT
作为变量'***目标值数组的Dim vntTV
Dim i As Long源/颜色数组列计数器
Dim k As Long“目标阵列行计数器
将sRow变暗为“长”颜色行
将SVal设置为字符串的搜索值
Dim Noe作为“元素源数量”
'将值从条件单元格范围写入搜索值。
SVal=ThisWorkbook.Worksheets（cTarget）.Range（CriteriaCell）
'在源工作表中
使用此工作簿。工作表（cSource）
'在“源条件”列中搜索搜索值并创建
'找到了对源单元格范围的引用。
设置rng=.Columns（cCriteriaColumn）_
.Find（SVal、xlValues、xlother、xlNext）
'检查是否未找到搜索值。退出，如果。
如果rng为空，则退出Sub
'将找到的源单元格范围的行写入颜色行。
sRow=rng.Row
'释放rng变量（不再需要）。
设置rng=无
'在源列中
带.Columns（cColumns）
'将标头范围复制到标头数组。
vntH=.Rows（cHeaderRow）
'将颜色范围复制到颜色数组。
vntC=.Rows（sRow）
'***将颜色范围复制到值数组。
'注意：值也会写入颜色数组，但是
'稍后将被颜色索引覆盖。
vntV=.Rows（sRow）
'将源列中的列数写入源编号
"元素"。
Noe=.Columns.Count
'循环通过颜色范围/数组的列。
对于i=1到Noe
'将颜色范围的当前颜色索引写入当前
'颜色数组中的元素。
vntC（1，i）=.单元（sRow，i）.内部颜色索引
下一个
以
以
'将目标数组调整为元素数行和一列。
ReDim vntT（1对Noe，1对1）
'***将目标值数组调整为元素数行和一列。
ReDim vntTV（1对Noe，1对1）
'循环通过颜色数组的列。
对于i=1到Noe
'检查颜色数组中的当前值是否等于条件
'列索引。
如果vntC（1，i）=cColindex，则
'对目标数组中的行进行计数。
k=k+1
'将标头数组中当前列的值写入
'元素在目标数组的当前行中。
vntT（k，1）=vntH（1，i）
'***将值数组中当前列的值写入
'元素在目标值数组的当前行中。
vntTV（k，1）=vntV（1，i）
如果结束
下一个
'删除标题和颜色数组（不再需要）。
擦除vntH
擦除vntC
删除vntV'***
'在目标工作表中
使用此工作簿。工作表（cTarget）
'通过调整交叉点处单元格的大小来计算目标范围
'按元素数设置目标第一行和目标列。
'将目标阵列复制到目标范围。
.单元格（cFr，cCol）.调整大小（Noe）=vntT
'***通过在指定位置调整单元格大小来计算目标值范围
'目标第一行和值列的交点，按
"要素"。
'将目标值数组复制到目标值范围。
.单元格（cFr，cColVal）.调整大小(
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

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