Sub УБРАТЬ_ДУБЛИКАТЫ()
On Error Resume Next
Dim objCloseBook As Object
Dim coll As Collection, folder$
Dim fPath$, fName$
Dim i&
    folder$ = "D:\Картинка"
    Set coll = FilenamesCollection(folder$, "*.*")        ' получаем список файлов из папки
n = coll.Count
For i = 1 To coll.Count    ' перебираем все элементы коллекции, содержащей пути к файлам
     
        'НомерФайла = i
        fPath = coll(i)
        ИмяФайла = Dir(fPath)
        fName = Left(ИмяФайла, InStrRev(ИмяФайла, ".") - 1)

If ИмяФайла = fName & ".tif" Then
MsgBox "КОПИЯ " & ИмяФайла
Kill "D:\Работа\ЧКД\" & ИмяФайла
End If
If ИмяФайла = fName & ".png" Then
MsgBox "КОПИЯ " & ИмяФайла
Kill "D:\Картинка\" & ИмяФайла
End If
Next
End Sub

Sub УБРАТЬ_ДУБЛИКАТЫ()
On Error Resume Next
Dim objCloseBook As Object
Dim coll As Collection, folder$
Dim fPath$, fName$
Dim i&
    'открываем диалоговое окно выбора папки
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку"
        .Show
        On Error Resume Next
        Err.Clear
        V = .SelectedItems(1)
        If Err.Number <> 0 Then
            MsgBox "Вы не выбрали папку!"
            Exit Sub
        End If
    End With
    folder$ = CStr(V)

    Set coll = FilenamesCollection(folder$, "*.*")        ' получаем список файлов из папки
n = coll.Count
For i = 1 To coll.Count    ' перебираем все элементы коллекции, содержащей пути к файлам
     
        fPath = coll(i)
        ИмяФайла = Dir(fPath)
        fName = Left(ИмяФайла, InStrRev(ИмяФайла, ".") - 1)

If ИмяФайла = fName & ".tif" Then
Kill folder$ & "\" & ИмяФайла
End If
If ИмяФайла = fName & ".png" Then
Kill folder$ & "\" & ИмяФайла
End If
Next
End Sub

Option Explicit
Option Compare Text '!!

Sub example_03()    'msoFileDialogFolderPicker
Dim Fold As String, f As String
Dim colJpg As New Collection

With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select the folder in which the files to be processed"
    .ButtonName = "Select": .AllowMultiSelect = False
    If .Show Then Fold = .SelectedItems(1) Else Exit Sub
End With

If Right(Fold, 1) <> "\" Then Fold = Fold & "\"
f = Dir(Fold & "*.*", vbNormal)
Do While f <> ""
    'нужно обнаружить одинаковые и удалить файлы .tif и .png если есть такой же .jpg
    If InStr(f, ".jpg") Then colJpg.Add f, Mid$(f, 1, InStrRev(f, ".") - 1)
    f = Dir()
Loop

On Error Resume Next: Err.Clear
f = Dir(Fold & "*.*", vbNormal)
Do While f <> ""
    If InStr(f, ".jpg") = 0 Then
        colJpg.Add f, Mid$(f, 1, InStrRev(f, ".") - 1)
        If Err Then
            Kill Fold & "\" & f
            Err.Clear
        End If
    End If
    f = Dir()
Loop
End Sub

Sub Удалить_дубли_файлов()

    Dim strFolder As String, collJPG As New Collection, collNotJPG As New Collection
    Dim strFileName As String
    Dim var, i As Long
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = 0 Then
            Exit Sub
        End If
        strFolder = .SelectedItems(1)
    End With
    
    strFileName = Dir(strFolder & "\*.jpg")
    Do While strFileName <> ""
        collJPG.Add Item:="", key:=Left(strFileName, InStrRev(strFileName, ".") - 1)
        strFileName = Dir()
    Loop
    If collJPG.Count = 0 Then
        MsgBox "Готово!", vbInformation
        Exit Sub
    End If
    
    strFileName = Dir(strFolder & "\")
    Do While strFileName <> ""
        If LCase(strFileName) Like "*.tif" Or LCase(strFileName) Like "*.png" Then
            collNotJPG.Add Item:=strFolder & "\" & strFileName
        End If
        strFileName = Dir()
    Loop
    If collNotJPG.Count = 0 Then
        MsgBox "Готово!", vbInformation
        Exit Sub
    End If
    
    On Error Resume Next
    For i = collNotJPG.Count To 1 Step -1
        var = Mid(collNotJPG(i), InStrRev(collNotJPG(i), "\") + 1)
        var = Left(var, InStrRev(var, ".") - 1)
        If collJPG(var) = "" Then
        End If
        If Err.Number = 0 Then
            Kill collNotJPG(i)
        Else
            Err.Number = 0
        End If
    Next i
    On Error GoTo 0
    
    MsgBox "Готово!", vbInformation
    
End Sub