Sub ClearDupes()
    Dim avI, lr As Long, lLastR As Long
    Dim x
    Dim dicEmails As Object
    Dim sFolder As String, sFiles As String
    Dim wbAct As Workbook, wsSh As Worksheet
    Dim rD As Range
    
    Set dicEmails = CreateObject("scripting.dictionary")
    dicEmails.comparemode = 1
    lLastR = Cells(Rows.Count, 1).End(xlUp).Row
    avI = Cells(1, 1).Resize(lLastR).Value
    For Each x In avI
        If dicEmails.exists(x) = False Then
            dicEmails.Add x, 0&
        End If
    Next

    sFolder = ThisWorkbook.Path
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        If sFiles <> ThisWorkbook.Name Then
            Set wbAct = Workbooks.Open(sFolder & sFiles)
            Set wsSh = wbAct.Sheets(1) ' просматриваем только на первом листе
            lLastR = wsSh.Cells(wsSh.Rows.Count, 3).End(xlUp).Row 'последняя строка в столбце С
            avI = wsSh.Cells(1, 3).Resize(lLastR).Value
            Set rD = Nothing
            For lr = 1 To lLastR
                x = avI(lr, 1)
                If dicEmails.exists(x) Then
                    If rD Is Nothing Then
                        Set rD = wsSh.Cells(lr, 1)
                    Else
                        Set rD = Union(rD, wsSh.Cells(lr, 1))
                    End If
                End If
            Next
            If Not rD Is Nothing Then
                rD.EntireRow.Delete
            End If
            wbAct.Close 1
        End If
        sFiles = Dir
    Loop
End Sub