Sub LocDNtheoMau()
Dim Rng As Range, i As Long, c As Long, rAr As Variant
Dim Dic As Object, k As Long
Set Rng = Sheet1.Range("A2:D" & Sheet1.Range("A65535").End(xlUp).Row)
ReDim rAr(1 To Rng.Rows.Count, 1 To 3)
Set Dic = CreateObject("Scripting.Dictionary")
c = Sheet1.Range("H1").Font.ColorIndex
Sheet2.Range("B3:D500").ClearContents
For i = 1 To Rng.Rows.Count
If Rng(i, 1).Font.ColorIndex = c Then
If Not Dic.Exists(Rng(i, 1).Value) Then
k = k + 1: Dic.Add Rng(i, 1).Value, k
rAr(k, 1) = Rng(i, 1).Value
rAr(k, 2) = Rng(i, 2).Value
rAr(k, 3) = Rng(i, 4).Value
End If
End If
Next i
If k Then Sheet2.Range("B3").Resize(k, 3) = rAr
Set Rng = Nothing: Set Dic = Nothing
End Sub
