颜色搜索
在标准模块中（转到 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
在 Worksheet Formulier 中（在 VBE 中双击 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
白色单元格值版本
- 添加了将白色单元格的值写入工作表的 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