Match font color works ... but

[BrianDP1977]

With a lot of help on another site, the following code was developed t
match the font color of certain cell data on one sheet with matchin
data in a database (i.e. if a name matches one in the database, matc
the font color of the name in the database).

Code 1 (this is inserted on a module and is the subject of my problem
because it uses a dictionary object):


Code
-------------------
Sub Namecolors(RngN As Range, RngD As Range)
Dim dicNames As New Dictionary
Dim c As Range

For Each c In RngN
If dicNames.Exists(c.Value) Then 'name in rngNames exists in dicNames
dicNames.Remove (c.Value) 'delete existing entry to read in new one
End If
dicNames.Add c.Value, c.Font.Color 'read name into dicNames and associate font color value
Next

For Each c In RngD
If dicNames.Exists(c.Value) Then 'cell value exists in dicNames
c.Font.Color = dicNames.Item(c.Value) 'set font color to associated value
Else
c.Font.Color = RGB(0, 0, 0) 'else, set font color to black
End If
Next
End Su
-------------------


Code 2 (inserted on the destination sheet … simply calls the Namecolor
code whenever a change occurs to the specified cells):


Code
-------------------
'Populate cells with matching font color
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, RngNames As Range, RngDesired As Range

Set RngDesired = Range("A12")
Set RngNames = Worksheets("Extended List").Range("A1:B100")

On Error Resume Next
For Each c In RngDesired ' Cells.SpecialCells(xlCellTypeFormulas)
Call Namecolors(RngNames, RngDesired)
Next c
End Sub
-------------------


This code works great for what I need (i.e. it changes the font color
exactly as advertised). However, I would like it formatted such that i
does not require the use of a Dictionary object (i.e. I’m going to b
using this spreadsheet for communications purposes (i.e. sending it i
e-mails) and not everyone who opens it will have the Microsof
Scripting Runtime enabled (which is required for this code to work) an
I don’t want to have to explain how to enable it every time I send i
out)

 

[paul.robinson]

Hi
You can replace the dictionary with a collection. The code below is not
tested.

Code 1
Code:
--------------------
Sub Namecolors(RngN As Range, RngD As Range)
Dim dicNames As New Collection
Dim c As Range

On error resume next
For Each c In RngN
Err.Clear 'Use error object to see if c.Value already exists in
dicNames
dicNames.Add c.Font.Color, Cstr(c.Value)
If Err.Number<>0 then 'c.Value already exists so remove it
dicNames.Remove Cstr(c.Value)
dicNames.Add c.Font.Color, Cstr(c.Value)
end if
Next

For Each c In RngD
Err.Clear
c.Font.Color = dicNames.Item(Cstr(c.Value)) 'Generates an error if
c.Value is not in

dicNames
If Err.Number<>0 then
c.Font.Color = RGB(0, 0, 0) 'else, set font color to black
End If
Next
On error goto 0
End Sub

 

[BrianDP1977]

Works great. I had tried a collection earlier but I obviously did
something wrong. Thanks for the help.