Option Compare Text

Sub ВашМакрос()
    On Error Resume Next
    BaseFolder$ = "G:\Департамент\06.2016\"
    Person$ = "Орлов"

    Dim coll As Collection, MaxIndex&, ind&
    ' ищем папку Орлова
    Set coll = SubFoldersCollection(BaseFolder$, "* " & Person$)
    If coll.Count > 0 Then
        MsgBox "Уже есть папки для " & Person$ & " в количестве " & coll.Count & " шт"
        MsgBox "Используйте папку" & vbNewLine & coll(1)
        Exit Sub
    End If

    ' перебираем все элементы коллекции, содержащей пути к папкам
    For Each folder In SubFoldersCollection(BaseFolder$, "*")        ' подпапки с любыми именами
        FolderName = Split(folder, "\")(UBound(Split(folder, "\")) - 1)
        ind& = Val(FolderName)
        If ind& > MaxIndex& Then MaxIndex& = ind&
    Next

    NewFolderName$ = MaxIndex& + 1 & " " & Person$
    MkDir BaseFolder$ & NewFolderName$
    MsgBox "Создана новая папка: " & vbNewLine & BaseFolder$ & NewFolderName$

End Sub

Function SubFoldersCollection(ByVal FolderPath$, Optional ByVal Mask$ = "*") As Collection
    Set SubFoldersCollection = New Collection        ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")        ' создаём экземпляр FileSystemObject
    If Right(FolderPath$, 1) <> "\" Then FolderPath$ = FolderPath$ & "\"
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath$)
    For Each folder In curfold.SubFolders        ' перебираем все подпапки в папке FolderPath
        If folder.Path Like FolderPath$ & Mask$ Then SubFoldersCollection.Add folder.Path & "\"
    Next folder
    Set FSO = Nothing
End Function