Option
Explicit
Sub
Example()
Dim
col
As
New
VBA.Collection
Dim
colR
As
New
VBA.Collection
Dim
rngCell
As
Excel.Range
For
Each
rngCell
In
Worksheets(
"Tabelle1"
).Range(
"A1"
).CurrentRegion
If
Trim$(rngCell.Value) =
""
Then
rngCell.Interior.ColorIndex = XlColorIndex.xlColorIndexNone
Else
If
Not
KeyExists(Trim$(rngCell.Value), col)
Then
Call
col.Add(Key:=Trim$(rngCell.Value), Item:=
New
VBA.Collection)
Call
col(Trim$(rngCell.Value)).Add(Item:=rngCell)
End
If
Next
For
Each
colR
In
col
If
colR.Count > 1
Then
For
Each
rngCell
In
colR
rngCell.Interior.Color = rgbLightGreen
Next
Else
colR(1).Interior.Color = rgbRed
End
If
Next
End
Sub
Private
Function
KeyExists(
ByVal
Key
As
String
,
ByVal
Collection
As
VBA.Collection)
As
Boolean
On
Error
Resume
Next
KeyExists = TypeName(Collection(Key)) <>
""
End
Function