Sub Rename_File()
    Dim sFilePath As String, LastRow As Long, i As Long, myDict As Object
    Dim Cell As Range, oldName As String, newName As String
    sFilePath = Split(Range("A1").Text, " ", 3)(2)    'путь к текущей паке
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Set myDict = CreateObject("Scripting.Dictionary")
    For Each Cell In Range("B3:B" & LastRow)
        If Not myDict.Exists(Cell.Value) Then
            myDict.Add Cell.Value, WorksheetFunction.CountIf(Range("B3:B" & LastRow), Cell.Value)
        End If
    Next Cell
    If Right(sFilePath, 1) <> "\" Then sFilePath = sFilePath & "\"
    
    If Application.WorksheetFunction.CountA(Range("A3:A" & LastRow)) <> Application.WorksheetFunction.CountA(Range("B3:B" & LastRow)) Then Exit Sub
    
    For i = LastRow To 3 Step -1
        If Dir(sFilePath & Cells(i, 1).Text, 16) <> "" And _
           ThisWorkbook.FullName <> sFilePath & Cells(i, 1).Text And _
           ThisWorkbook.FullName <> sFilePath & Cells(i, 2).Text Then
            If myDict.Item(Cells(i, 2).Text) > 1 Then
                oldName = Cells(i, 1).Text
                newName = Mid(Cells(i, 2).Text, 1, InStrRev(Cells(i, 2).Text, ".")) & "(" & _
                myDict.Item(Cells(i, 2).Text) & ")" & _
                Mid(Cells(i, 2).Text, InStrRev(Cells(i, 2).Text, "."))
                myDict.Item(Cells(i, 2).Text) = myDict.Item(Cells(i, 2).Text) - 1
                'переименовываем файл(сo счётчикoм)
                Name sFilePath & oldName As sFilePath & newName
            Else
                'просто переименовываем файл(без счётчика)
                Name sFilePath & Cells(i, 1).Text As sFilePath & Cells(i, 2).Text
            End If
        End If
    Next i
    'Update file list
    Call ListFilesInFolder(sFilePath)
    Shell "explorer.exe " & sFilePath, vbNormalFocus
End Sub