Color Search

Question

我的数据表（“ srData”）是使用用户窗体填充的数据透视表。所有数据在数据表的A列中都有唯一的ID。在用户窗体复选框中选中，这将更改单元格，在K：AA列中，内部颜色为white（2），否则内部颜色为grey（15）

我需要做的是在另一张纸上（“配方商”），基于一个下拉框（C6）的值，在该框中选择了唯一ID（即SR-1，SR-2， SR-3等...），对表执行查找以返回标题，其中单元格的内部颜色为colorindex = 2。查找的结果需要放在A列的sheet（“ 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

我已经使用this post尝试了代码，但这并不是我想要的。由于此代码将标头allin放置在单元格上，并且它基于值而不是颜色。

我希望有人能够帮助我。

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

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

1 个答案:

Color Search

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

In Worksheet Formulier (In VBE double-click Formulier)

White Cell Values Version