Option Explicit
Public Sub Colorize()
On Error Resume Next
Dim baseRange As Excel.Range
Dim nextCell As Excel.Range, sKey As String
Dim pDict As Object, needCell As Excel.Range
Dim colorRange As Excel.Range
Set colorRange = ActiveSheet.Range("A1:E2")
Set pDict = CreateObject("Scripting.Dictionary")
For Each nextCell In colorRange
If (Not IsEmpty(nextCell.Value)) And IsNumeric(nextCell.Value) Then
sKey = CStr(CLng(nextCell.Value))
If Not pDict.Exists(sKey) Then pDict.Add sKey, nextCell
End If
Next nextCell
Set needCell = Nothing: Set baseRange = Nothing
Set baseRange = ActiveSheet.UsedRange.SpecialCells(XlCellType.xlCellTypeConstants, XlSpecialCellsValue.xlNumbers)
Set needCell = ActiveSheet.UsedRange.SpecialCells(XlCellType.xlCellTypeFormulas, XlSpecialCellsValue.xlNumbers)
If (Not baseRange Is Nothing) And (Not needCell Is Nothing) Then
Set baseRange = Application.Union(baseRange, needCell)
ElseIf Not needCell Is Nothing Then
Set baseRange = needCell
End If
If baseRange Is Nothing Then Exit Sub
If pDict.Count = 0 Then Exit Sub
For Each nextCell In baseRange
If (Not IsEmpty(nextCell.Value)) And IsNumeric(nextCell.Value) Then
sKey = CStr(CLng(nextCell.Value))
If Application.Intersect(nextCell, colorRange) Is Nothing Then
If pDict.Exists(sKey) Then
Set needCell = pDict.Item(sKey)
nextCell.Interior.Color = needCell.Interior.Color
End If
End If
End If
Next nextCell
End Sub
|
