Option ExplicitSub CreateFolders()
Dim sPath As String, FolderName As String
Dim objFSO As Object, objParentFolder As Object
Dim objChildFolder As Object
Dim lngValue&, sStartFoderFileName$, sFoderFileName$
Dim Number&, i&
    
    sPath = "C:Temp"
    
    If Dir(sPath, vbDirectory) = "" Then
        MkDir sPath
    End If
    
    Number = Application.InputBox("Сколько создать папок?", "Создание папок", 1, , , , , 1)
    If Number = 0 Then Exit Sub
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objParentFolder = objFSO.GetFolder(sPath)
   
    For i = 0 To Number - 1
        lngValue = 0
        sFoderFileName = ""
        For Each objChildFolder In objParentFolder.SubFolders
            sFoderFileName = ExtractValue(Right(objChildFolder.Name, 4))
            If lngValue < sFoderFileName Then
                lngValue = sFoderFileName
                sFoderFileName = objChildFolder.Name
            End If
        Next
    
        If lngValue < 9 Then sFoderFileName = "000"
        If lngValue >= 9 And lngValue < 99 Then sFoderFileName = "00"
        If lngValue >= 99 And lngValue < 999 Then sFoderFileName = "0"
        If lngValue >= 999 Then sFoderFileName = ""
        
        If sStartFoderFileName = "" Then sStartFoderFileName = Format(Date, "YYYY/MM/DD") & "_" & sFoderFileName & (lngValue + 1)
        
        sFoderFileName = Format(Date, "YYYY/MM/DD") & "_" & sFoderFileName & (lngValue + 1)
        
        objFSO.CreateFolder (sPath & sFoderFileName)
    Next i
    MsgBox "Папки в количестве " & Number & " созданы!" & Chr(10) & _
        "сохранены в папке: " & sPath & Chr(10) & _
        "Начальная папка: " & sStartFoderFileName, 64, "Конец"
End SubFunction ExtractValue(pstrText)
Dim objRegExp As Object, GetDigitsFromText&    On Error Resume Next
    Set objRegExp = CreateObject("VBScript.RegExp")
    With objRegExp
        .MultiLine = True
        .Global = True
        .Pattern = "D"
        GetDigitsFromText = .Replace(pstrText, vbNullString)
    End With
    ExtractValue = GetDigitsFromText
    On Error GoTo 0
    Set objRegExp = Nothing
End Function

В рамках одной из задач понадобилось создать папки с именами позиций заведенных в эксельку. Так как набралось больше сотни строк, да и в дальнейшем список грозит расширятся выполним эту задачу с помощью скрипта. Заодно добавим гиперссылок так, чтобы к каждой позиции у нас был доступ прямо из Эксель.
На выходе получаем список папок в экселе с со ссылками чтобы можно было их, папки, сразу открыть.

Sub Create_Folders()'для корректной работы необходимо выбрать ячейки перед тем как запустить макрос. Dim OpenAt As String 'Зададим каталог для папок по умолчанию.

OpenAt = «My computer:»

‘Вызовем диалог для выбора места папок.  Set ShellApp = CreateObject(«Shell.Application»).BrowseForFolder(0, «Please Choose The Folder For This Project», 0, OpenAt)

‘Устанавливаем выбранную папку в качестве рабочей. (в случае ошибки отменяем процесс) On Error Resume Next

BrowseForFolder = ShellApp.Self.Path

‘Выхватываем список выбранных ячеек.  Dim Rng As Range

Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count

‘—в цикле проходим все ячейки в нашем— For c = 1 To maxCols

r = 1
Do While r

Обидевшись на ваши ответы, и посидев немного с VBA все таки написал скрипт, хоть и вышел за пределы сроков. Надеюсь вам пригодится, так что я выложу его сюда

Sub Кнопка1_Щелчок() Dim i As Long Dim ActWB As Workbook Dim avInp(), fl As Object Dim Kol_pid, Pid, kol1 As Integer Dim Stolbec, StrokaOtsch As Integer Dim NameFile() As String Dim NewFoldPth, OldFoldPth, FoldPth, NewFolder1, NewFolder As String Dim ki, counter As Long Dim Fiyli() As String Dim Stolbec1 As String Dim iSheet As Integer ' Индекс листа Dim sFPName As String ' Имя последней папки перед нумерацией   Set FSO = CreateObject("Scripting.FileSystemObject")  Stolbec1 = Application.InputBox("Укажите номер столбца, в котором находятся наименования файлов", "Номер столбца", "3") Kol_pid = Application.InputBox("Укажите количество файлов в папке",  "Номер папки", "3") StrokaOtsch = Application.InputBox("Укажите номер строки начала данных", "Номер строки", "3") StolbecOut = Application.InputBox("Укажите номер столбца куда писать пути", _ "Номер столбца", "3")   Stolbec = CInt(Stolbec1) StrokaOtsch = CInt(StrokaOtsch) StolbecOut = CInt(StolbecOut)  Application.ScreenUpdating = False i1_n = Cells(Rows.Count, Stolbec).End(xlUp).Row Set ActWB = ActiveWorkbook iSheet = ActiveSheet.Index  ' NewFolder = Application.InputBox("Укажите имя папки, в которую необходимо перенести файлы", "Имя новой папки", _ ' "Файлы из списка")  ' StrokaOtsch = Application.InputBox("Укажите номер строки, в которой находится шапка таблицы", _ ' "Номер строки", "1") ' NewFolder = "fileout" ' counter = 3  ' StrokaOtsch = "1" Pid = 1   With Application.FileDialog(msoFileDialogFolderPicker)     .Title = "как сделать папку в excel"     .ButtonName = "Select": .AllowMultiSelect = False     If .Show Then FoldPth = .SelectedItems(1) Else Exit Sub End With  With Application.FileDialog(msoFileDialogFolderPicker)     .Title = "как сделать папку в excel"     .ButtonName = "Select": .AllowMultiSelect = False      If .Show Then NewFolderPath = .SelectedItems(1) Else Exit Sub     'MsgBox (.SelectedItems(1)) End With  'NewFolderPath = NewFolderPath & ""    Time_1 = Timer If Right(NewFolder, 1)  "" Then NewFolder = NewFolder & "" If Right(FoldPth, 1)  "" Then FoldPth = FoldPth & ""  bbb = Split(NewFolderPath, "")  sFPName = bbb(UBound(bbb))   ReDim NameFile(i1_n - StrokaOtsch)  'For i1 = 1 To i1_n - StrokaOtsch + 1 '    If Cells(StrokaOtsch + i1 - 1, Stolbec)  "" Then '    n = n + 1 '    NameFile(n) = Cells(StrokaOtsch + i1 - 1, Stolbec) '    End If ' Next i1  ReDim Preserve NameFile(n) Set FSO = CreateObject("Scripting.FileSystemObject") With FSO          If Not .FolderExists(NewFolderPath & "" & Pid & "") Then .CreateFolder NewFolderPath & "" & Pid & ""         'создание нового каталога куда копировать каталога     With .GetFolder(FoldPth)         ' If .Files.Count = 0 Then MsgBox "Файлов в указанном пути не найдено", 48: Exit Sub         'проверка наличия файлов откуда происходит копирование         '  ReDim Fiyly(.Files.Count)       '      For Each fl In .Files       '          ki = ki + 1       '          Fiyly(ki) = fl.Name                 ' MsgBox (Fiyly(ki))  Заполнение массива именами файлов, находящихся в каталоге которые надо копировать       '      Next fl                 kol1 = 1             For i1 = StrokaOtsch To i1_n        '     For i = 1 To UBound(Fiyly)              If Cells(i1, Stolbec)  "" Then                  ' MsgBox (Cells(i1, Stolbec))                   '  NameFile(i1) = Cells(i1, Stolbec)         '        If Fiyly(i) = NameFile(i1) Then                     If kol1 = Kol_pid + 1 Then                         Pid = Pid + 1                         With FSO                             If Not .FolderExists(NewFolderPath & "" & Pid & "") Then .CreateFolder NewFolderPath & "" & Pid & ""                         End With                         kol1 = 1                     End If                 ' MsgBox (FoldPth & NameFile(i1) & "Новая куда" & NewFolderPath)                 If FSO.FileExists(FoldPth & Cells(i1, Stolbec)) Then                      Kol = Kol + 1                      kol1 = kol1 + 1                       FSO.MoveFile FoldPth & Cells(i1, Stolbec), NewFolderPath & "" & Pid & ""                     ActWB.Sheets(iSheet).Cells(i1, StolbecOut).Value = sFPName & "" & Pid & "" & Cells(i1, Stolbec)                 End If          '       End If            '  Next i              End If             Next i1     End With End With time_ = Time_1 - Timer Time_delta = Format(time_ / 24 / 60 / 60, "hhч mmм ssс") Application.ScreenUpdating = True MsgBox ("Выполнено за " & Time_delta & Chr(13) & "Количество перемещённых файлов :" & Kol) End Sub