12/04/09 07:58:24.87
>>924
あんまり綺麗なコードじゃないけど、めんどくさいから最小限の修正で
Sub W()
Dim j As Long
Dim ws2 As Worksheet
Dim r As Range
Dim c As Object
Set ws2 = Worksheets("Sheet2")
Set r = Range("A1:A10") 'ここに色を付けたいセル範囲を書く
If Intersect(r, Columns(1)) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
r.Interior.ColorIndex = xlNone
For Each c In r
If WorksheetFunction.CountIf(ws2.Columns(1), c) Then
j = WorksheetFunction.Match(c, ws2.Columns(1), False)
c.Interior.ColorIndex = ws2.Cells(j, 2).Interior.ColorIndex
End If
Next
Application.ScreenUpdating = True
End Sub