Поиск и пометка повторяющихся значений

Dim h
Set h = CreateObject("Scripting.Dictionary")

Range("A1:A100").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1:B100"), Unique:=True

Sub getTheSame()
 On Error GoTo errh: 'Óñòàíàâëèâàåì õåíäëåð îøèáîê
 Dim h As New Scripting.dictionary 'Ñîçäàåì õåø - ìíîæåñòâî ïàð "êëþ÷" -> çíà÷åíèå
 Dim rg As Range
 Set rg = Columns(2).Cells.SpecialCells(xlCellTypeConstants) 'Áåðåì òîëüêî êîíñòàíòû èç êîëîíêè 2
 Dim c As Range
 Dim i As Long
 For Each c In rg.Cells 'Ïåðåáèðàåì âñå ÿ÷åéêè èç ìíîæåñòâà
 DoEvents 'Äàåì Ýêñåëþ âîçìîæíîñòü îòðèñîâàòüñÿ
 ActiveWindow.Caption = c.Address 'Ìîæíî åùå àäðåñ ÿ÷åéêè ïîêàçûâàòü - ÷òîá áûë âèäåí ïðîãðåññ
 h(c.Value) = h(c.Value) + 1 ' Åñëè êëþ÷ íå ñóùåñòâîâàë, õåø åãî àâòîìàòè÷åñêè äîáàâèò, èíà÷å óâåëè÷èò ê-âî ïîâòîðåíèé êëþ÷à
  If h(c.Value) > 1 Then 'Åñëè êëþ÷ âñòðå÷àëñÿ áîëåå 1 ðàçà
   c.Offset(0, 1).Value = "Exists" 'Ñòàâèì â ñîñåäíåé ÿ÷åéêå Exists
   c.Interior.ColorIndex = Array(38, 40, 36, 35, 34, 37, 39, 7, 44, 6, 4, 8, 33, 3, 45, 42)(i Mod 15)
   c.Offset(0, 1).Interior.ColorIndex = c.Interior.ColorIndex
   i = i + 1
  End If
 Next c
 Set h = Nothing 'Îñâîáîæäàåì ïàìÿòü èç ïîä õåøà
 MsgBox "Done", vbInformation ' Íó è äëÿ íàãëÿäíîñòè ïëàêàò îá îêîí÷àíèè
 '=============================
 If 0 Then 'Ñþäà ïîïàäåì òîëüêî â ñëó÷àå îøèáêè
errh:       ' îáû÷íûõ óñëîâèÿõ if 0 íèêîãäà íå ñðàáîòàåò
  Set h = Nothing 'Åñëè âîçíè

Option Explicit
Sub getTheSame()
 On Error GoTo errh:
 Dim h As New Scripting.dictionary
 Dim rg As Range
 Set rg = Columns(2).Cells.SpecialCells(xlCellTypeConstants)
 Dim c As Range
 Dim i As Long, tc As Long
 Dim un As Range: Set un = Nothing
 For Each c In rg.Cells
 DoEvents
 ActiveWindow.Caption = c.Address
 h(c.Value) = h(c.Value) + 1
  If h(c.Value) > 1 Then
   c.Offset(0, 1).Value = "Exists"
    tc = Array(38, 40, 36, 35, 34, 37, 39, 7, 44, 6, 4, 8, 33, 3, 45, 42)(i Mod 15)
   c.Interior.ColorIndex = tc
   c.Offset(0, 1).Interior.ColorIndex = tc
   i = i + 1
     If un Is Nothing Then
        Set un = c
     Else
        Set un = Union(un, c)
     End If
   End If
 Next c
 Set h = Nothing
 MsgBox "Done", vbInformation
 un.Select
 '=============================
 If 0 Then
errh:
  Set h = Nothing
  MsgBox Err.Description
 End If
'==============================
End Sub

Private Sub CommandButton1_Click()
    BuildXMLRecordset
    ReadXMLData
End Sub

Option Explicit
Sub BuildXMLRecordset()
    Dim objMyRcrdst As ADODB.Recordset
    Dim objMyStream As ADODB.Stream
    Dim strCnctn As String
    Dim strSQL As String
    strSQL = "SELECT F1, COUNT(F1)  FROM [Report] GROUP BY F1;" 'Report - это имя ранга, в котором все данные, подразумевается в одном столбце
    strCnctn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & ThisWorkbook.FullName & ";" & _
    "Extended Properties=""Excel 8.0;HDR=No"";"
     
    Set objMyRcrdst = New ADODB.Recordset
    Set objMyStream = New ADODB.Stream
     
    With objMyRcrdst
        
        .CursorLocation = adUseClient
        .Open strSQL, strCnctn, adOpenStatic, adLockReadOnly, adCmdText
         'Save the recordset into the stream.
        .Save objMyStream, adPersistXML
        .Close
        With objMyStream
            .SaveToFile "C:Report.xml", adSaveCreateOverWrite
            .Close
        End With
    End With
     
    Set objMyStream = Nothing
    Set objMyRcrdst = Nothing
     
End Sub
Sub ReadXMLData()
    Dim objMyRcrdst As ADODB.Recordset
    Dim strCnctn As String
    Dim strFile As String
     
    Set objMyRcrdst = New ADODB.Recordset
     
    strFile = "C:Report.xml"
    strCnctn = "Provider=MSPersist;"
    With objMyRcrdst
        .CursorLocation = adUseClient
        .Open strFile, strCnctn, adOpenStatic, adLockReadOnly, adCmdFile
        Set .ActiveConnection = Nothing
    End With
     
    With ActiveSheet
         'Copy the data from the recordset.
        .Range("B2").CopyFromRecordset objMyRcrdst
    End With
    objMyRcrdst.Close
    Set objMyRcrdst = Nothing
     
End Sub