Sub iii()
    Dim Col As New Collection
    Dim Coln As New Collection
    put_ = ThisWorkbook.Path
    If Right(put_, 1) <> "\" Then put_ = put_ & "\"
    fn_ = Dir(put_)
    On Error Resume Next
    Do While fn_ <> ""
        If fn_ <> ActiveWorkbook.Name Then
            n_ = CInt(Left(fn_, InStr(Left(fn_, InStrRev(fn_, ".") - 1), ".") - 1))
            If Err Then
                Err.Clear
                Col.Add fn_ 'коллекция названий без номеров
            Else
                Coln.Add n_ 'коллкция имеющихся номеров
            End If
        End If
        fn_ = Dir
    Loop
    With Coln 'сортировка номеров в коллекции
        For i = 1 To .Count - 1
            For j = i + 1 To .Count
                If .Item(i) > .Item(j) Then
                    aaa = .Item(j)
                    .Remove j
                    .Add aaa, , i
                End If
            Next j
        Next i
        z_ = 0
        On Error GoTo A 'выход при нехватке файлов
        For i = 1 To .Count
            nom_ = .Item(i)
            If nom_ <> z_ + 1 Then
                For j = z_ + 1 To nom_ - 1
                    Name put_ & Col(1) As put_ & j & "." & Col(1)
                    Col.Remove 1
                Next j
                z_ = nom_
            Else
                z_ = z_ + 1
            End If
        Next i
    End With
    With Col 'оставшиеся файлы
        For i = 1 To .Count
            nom_ = nom_ + 1
            Name put_ & Col(1) As put_ & nom_ & "." & Col(1)
            .Remove 1
        Next i
    End With
A:
    MsgBox "Файлы пронумерованы"
End Sub