Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
Private fRN_TimerID As Long
Function FillColorByCondition(Optional ByVal Target As Range, _
Optional ByVal ConditionsValue, _
Optional ByVal Column, _
Optional ByVal BackcolorDefault As Long = -1, _
Optional ByVal NameForCell As String = "")
FillColorByCondition = NameForCell
On Error Resume Next
Static a, b, c, d As Boolean, e As Long, i, j, p As Long, l As Long
If fRN_TimerID <> 0 Then KillTimer 0&, fRN_TimerID
If VBA.TypeName(Application.Caller) = "Range" Then
Set a = Target
If VBA.TypeName(ConditionsValue) = "Range" Then
Set b = ConditionsValue
l = b.Rows.Count: p = 1
Else
b = ConditionsValue
l = UBound(b)
End If
If VBA.IsNumeric(Column) Then
c = CLng(Column)
Else
c = Columns(Column).Column - Target.Column + 1
End If
e = BackcolorDefault
fRN_TimerID = SetTimer(0&, 0&, 1, AddressOf FillColorByCondition_Callback)
Else
Dim k As Long, bb, r() As Range, o, h, m As Boolean, n As Long, y, z
o = a.Value: h = a.Columns.Count
n = a(a.Rows.Count, 1).End(3).Row - a(1, 1).Row + 1
If n > 0 Then
ReDim r(1 To l) As Range
If p > 0 Then
bb = b.Value: bb = Application.Transpose(bb)
y = 1
Else
y = 2
End If
For i = 1 To n
For j = 1 To l Step y
If o(i, c) = bb(j) Then
k = k + 1
If r(j) Is Nothing Then
Set r(j) = a(i, 1).Resize(, h)
Else
Set r(j) = Application.Union(a(i, 1).Resize(, h), r(j))
End If
Exit For
End If
Next j
Next i
If k Then
Dim SU As Boolean
SU = Application.ScreenUpdating
Application.ScreenUpdating = False
If e >= 0 Then
a.Interior.Color = e
Else
a.Interior.Pattern = xlNone
End If
'--------------------------------
For j = 1 To l Step y
If Not r(j) Is Nothing Then
If p > 0 Then
If b(j, 1).Interior.Pattern = xlNone Then
z = -1
Else
z = b(j, 1).Interior.Color
End If
Else
z = b(j + 1)
End If
If z >= 0 Then
r(j).Interior.Color = z
Else
r(j).Interior.Pattern = xlNone
End If
End If
Next j
'--------------------------------
Application.ScreenUpdating = SU
End If
Set a = Nothing
If p > 0 Then Set b = Nothing
End If
End If
End Function
Private Sub FillColorByCondition_Callback()
Call FillColorByCondition
End Sub
