Excel vba создание папки: VBA Excel. Создание, копирование, перемещение папок

VBA Excel. Создание, копирование, перемещение папок

Создание, копирование, перемещение и удаление папок в VBA Excel методами объекта FileSystemObject. Удаление папок с помощью оператора RmDir.

1.
Создание папки (метод CreateFolder)

1.1.
Синтаксис

1.2.
Параметры

2.
Копирование папки (метод CopyFolder)

2.1.
Синтаксис

2.2.
Параметры

3.
Перемещение папки (метод MoveFolder)

3.1.
Синтаксис

3.2.
Параметры

4.
Удаление папки (метод DeleteFolder)

4.1.
Синтаксис

4.2.
Параметры

5.
Удаление папки (оператор RmDir)

5.1.
Синтаксис

6.
Примеры

Создание папки (метод CreateFolder)

CreateFolder – это метод объекта FileSystemObject, предназначенный для создания новой папки.

Синтаксис

object.CreateFolder (foldername)

Параметр foldername можно в скобки не заключать.

Параметры

ПараметрОписание
objectПеременная, возвращающая объект FileSystemObject.
foldernameСтроковое выражение, указывающее папку, которую необходимо создать.

Если папка, указанная параметром foldername уже существует, произойдет ошибка.

Копирование папки (метод CopyFolder)

CopyFolder – это метод объекта FileSystemObject, предназначенный для копирования папки из одного расположения в другое.

Синтаксис

object.CopyFolder source, destination, [overwrite]

Параметры

ПараметрОписание
objectПеременная, возвращающая объект FileSystemObject.
sourceСтроковое выражение, указывающее папку, которую требуется скопировать в другое расположение. Для копирования нескольких папок используются подстановочные знаки.
destinationСтроковое выражение, задающее конечное расположение, куда требуется скопировать папку (папки) со всеми вложениями из элемента source. Подстановочные знаки не допускаются.
overwriteЛогическое значение, которое указывает, требуется ли перезаписывать существующие папки и файлы в конечном расположении. True – папки и файлы будут перезаписаны, False – перезапись не выполняется. Необязательный параметр. По умолчанию – True.

Перемещение папки (метод MoveFolder)

MoveFolder – это метод объекта FileSystemObject, предназначенный для перемещения папки из одного расположения в другое.

Синтаксис

object.MoveFolder (source, destination)

Параметры

ПараметрОписание
objectПеременная, возвращающая объект FileSystemObject.
sourceСтроковое выражение, указывающее папку, которую требуется переместить в другое расположение. Для перемещения нескольких папок используются подстановочные знаки.
destinationСтроковое выражение, задающее конечное расположение, куда требуется переместить папку (папки) со всеми вложениями из элемента source. Подстановочные знаки не допускаются.

Удаление папки (метод DeleteFolder)

DeleteFolder – это метод объекта FileSystemObject, предназначенный для удаления папки с диска со всем ее содержимым.

Синтаксис

object.DeleteFolder folderspec, [force]

Параметры

ПараметрОписание
objectПеременная, возвращающая объект FileSystemObject.
folderspecСтроковое выражение, указывающее папку, которую следует удалить. Для удаления нескольких папок используются подстановочные знаки.
forceЗначение типа Boolean: True – удаляются все папки, False (по умолчанию) – не удаляются папки с атрибутом «только для чтения» (необязательный параметр).

Метод DeleteFolder удаляет папки независимо от того, есть ли в них содержимое или нет.

Удаление папки (оператор RmDir)

RmDir – это оператор, предназначенный для удаления пустых папок и каталогов.

Синтаксис

RmDir path

  • path – строковое выражение, определяющее каталог или папку, которую необходимо удалить.

Если удаляемый каталог или папка содержит файлы, произойдет ошибка.

Примеры

Пример 1
Создание папок в VBA Excel с помощью метода CreateFolder:

1

2

3

4

5

6

7

8

9

10

11

12

Sub Primer1()

Dim fso As Object, i As Integer

‘Создаем новый экземпляр FileSystemObject

Set fso = CreateObject(«Scripting. FileSystemObject»)

‘Создаем несколько новых папок

    With fso

        .CreateFolder («C:\Папка главная»)

            For i = 1 To 5

                .CreateFolder «C:\Папка главная\Папка » & i

            Next

    End With

End Sub

В результате работы этого кода на диске C будет создана Папка главная и в ней еще 5 папок, которые будем использовать для копирования, перемещения и удаления.

Пример 2
Копирование папок в VBA Excel с помощью метода CopyFolder:

1

2

3

4

5

6

7

8

9

Sub Primer2()

Dim fso As Object

Set fso = CreateObject(«Scripting.FileSystemObject»)

‘Копируем папки

    With fso

        .CopyFolder «C:\Папка главная\Папка 2», «C:\Папка главная\Папка 1\»

        .CopyFolder «C:\Папка главная\Папка 3», «C:\Папка главная\Папка 1\Папка 2\»

    End With

End Sub

Код этого примера копирует папки следующим образом: Папка 2 в Папка 1, а Папка 3 в расположение \Папка 1\Папка 2\.

Пример 3
Перемещение папок в VBA Excel с помощью метода MoveFolder:

1

2

3

4

5

6

7

8

9

10

Sub Primer3()

Dim fso As Object

Set fso = CreateObject(«Scripting.FileSystemObject»)

‘Перемещаем папки

    With fso

        .MoveFolder «C:\Папка главная\Папка 3», «C:\Папка главная\Папка 2\»

        .MoveFolder «C:\Папка главная\Папка 4», «C:\Папка главная\Папка 2\»

        .MoveFolder «C:\Папка главная\Папка 5», «C:\Папка главная\Папка 2\Папка 4\»

    End With

End Sub

Пример 4
Удаление папок в VBA Excel с помощью метода DeleteFolder:

1

2

3

4

5

6

7

8

9

Sub Primer4()

Dim fso As Object

Set fso = CreateObject(«Scripting. FileSystemObject»)

‘Удаляем папки с содержимым

    With fso

        .DeleteFolder «C:\Папка главная\Папка 1»

        .DeleteFolder «C:\Папка главная\Папка 2»

    End With

End Sub

Пример 5
Удаление пустой папки в VBA Excel с помощью оператора RmDir:

Sub Primer5()

‘Удаляем пустую папку

    RmDir «C:\Папка главная»

End Sub

Содержание рубрики VBA Excel по тематическим разделам со ссылками на все статьи.

excel — VBA — как создать папки и переместить туда файлы?

Обидевшись на ваши ответы, и посидев немного с 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 = "Папка Откуда копировать файлы"
    .ButtonName = "Select": .AllowMultiSelect = False
    If .Show Then FoldPth = .SelectedItems(1) Else Exit Sub
End With
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Папка Куда копировать файлы"
    .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

Создать папку и подпапку в Excel VBA

спросил

Изменено
6 месяцев назад

Просмотрено
267 тысяч раз

У меня есть выпадающее меню компаний, которое заполнено списком на другом листе. Три столбца: компания, номер задания и номер детали.

При создании задания мне нужна папка для указанной компании и подпапка для указанного номера детали.

Если пройти по пути, он будет выглядеть так:

C:\Изображения\Название компании\Номер детали\

Если существует название компании или номер детали, не создавайте или перезапишите старый. Просто перейдите к следующему шагу. Поэтому, если обе папки существуют, ничего не происходит, если одна или обе не существуют, создайте их по мере необходимости.

Другой вопрос, есть ли способ сделать так, чтобы он работал на Маках и ПК одинаково?

  • excel
  • vba
  • macos
  • каталог
  • создать каталог

16

Еще одна простая версия, работающая на ПК:

 Sub CreateDir(strPath As String)
    Тусклый вяз Как вариант
    Dim strCheckPath как строка
    стрчеккпас = ""
    Для каждого вяза в Split(strPath, "\")
        strCheckPath = strCheckPath & вяз & "\"
        Если Len(Dir(strCheckPath, vbDirectory)) = 0, тогда MkDir strCheckPath
    Следующий
Конец сабвуфера

5

Одна вспомогательная и две функции. Sub строит ваш путь и использует функции, чтобы проверить, существует ли путь, и создать, если нет. Если полный путь уже существует, он просто пройдет мимо.
Это будет работать на ПК, но вам нужно будет проверить, что нужно изменить, чтобы работать и на Mac.

 'требуется ссылка на Microsoft Scripting Runtime
Подпрограмма MakeFolder()
Dim strComp как строка, strPart как строка, strPath как строка
strComp = Range("A1") ' принимает название компании в A1
strPart = CleanName(Range("C1")) ' принимает участие в C1
strPath = "C:\Изображения\"
Если ПапкаНе существует(strPath и strComp), то
'компания не существует, поэтому создайте полный путь
    ПапкаСоздать strPath & strComp & "\" & strPart
Еще
'компания существует, но разделяет папку
    Если папка не существует (strPath & strComp & "\" & strPart), то
        ПапкаСоздать strPath & strComp & "\" & strPart
    Конец, если
Конец, если
Конец сабвуфера
Функция FolderCreate (путь ByVal как строка) как логическое значение
ПапкаСоздать = Истина
Dim fso как новый FileSystemObject
Если Functions. FolderExists(путь) Тогда
    Выход из функции
Еще
    При ошибке Перейти к DeadInTheWater
    fso.CreateFolder path ' может ли быть какая-то ошибка с этим, например, если путь действительно облажался?
    Выход из функции
Конец, если
Мертвые в воде:
    MsgBox "Не удалось создать папку для следующего пути: " & путь & ". Проверьте имя пути и повторите попытку."
    ПапкаКреате = Ложь
    Выход из функции
Конечная функция
Функция FolderExists (путь ByVal в виде строки) в виде логического значения
ПапкаЕсть = Ложь
Dim fso как новый FileSystemObject
Если fso.FolderExists(путь), то FolderExists = True
Конечная функция
Функция CleanName(strName as String) as String
'удалит имя части #, чтобы его можно было преобразовать в правильное имя папки
'может потребоваться добавить больше строк, чтобы избавиться от других символов
    CleanName = Заменить (strName, "/", "")
    CleanName = Заменить(CleanName, "*","")
    и т. д...
Конечная функция

16

Я нашел гораздо лучший способ сделать то же самое, меньше кода, гораздо эффективнее. Обратите внимание, что «»»» означает заключение пути в кавычки, если он содержит пробелы в имени папки. Командная строка mkdir создает любую промежуточную папку, если необходимо, чтобы существовал весь путь.

 Если Dir(YourPath, vbDirectory) = "" Тогда
    Оболочка ("cmd /c mkdir """ & YourPath & """")
Конец, если

4

 Частная подпрограмма CommandButton1_Click()
    Dim fso как объект
    Dim fldrname As String
    Dim fldrpath как строка
    Установите fso = CreateObject("scripting.filesystemobject")
    fldrname = Формат(Сейчас(), "дд-мм-гггг")
    fldrpath = "C:\Temp\" & имя_флдр
    Если Не fso.FolderExists(fldrpath) Тогда
        fso.createfolder (fldrpath)
    Конец, если
Конец сабвуфера

1

Здесь есть несколько хороших ответов, поэтому я просто добавлю некоторые улучшения процесса. Лучший способ определить, существует ли папка (не использует FileSystemObjects, которые разрешено использовать не всем компьютерам):

 Функция FolderExists(FolderPath As String) As Boolean
     Папкасуществует = Истина
     При ошибке Возобновить Далее
     Путь к папке ChDir
     Если Err <> 0, то FolderExists = False
     При ошибке Перейти к 0
Конечная функция

Аналогично,

 Функция FileExists(FileName As String) As Boolean
     Если Dir(FileName) <> "" Then FileExists = True Иначе FileExists = False
Конечная функция
 
 Функция MkDir (ByVal strDir как строка)
    Dim fso: Set fso = CreateObject("Scripting. FileSystemObject")
    Если Не fso.FolderExists(strDir) Тогда
        ' создать родительскую папку, если она не существует (рекурсивно)
        MkDir (fso.GetParentFolderName(strDir))
        ' не существует, поэтому создайте папку
        fso.CreateFolder strDir
    Конец, если
Конечная функция

3

Это прекрасно работает в AutoCad VBA, и я взял его с форума Excel. Я не знаю, почему вы все так усложняете?

ЧАСТО ЗАДАВАЕМЫЕ ВОПРОСЫ

Вопрос: Я не уверен, что конкретный каталог уже существует. Если он не существует, я хотел бы создать его с помощью кода VBA. Как я могу это сделать?

Ответ: Вы можете проверить, существует ли каталог, используя приведенный ниже код VBA:

(Цитаты ниже опущены во избежание путаницы в программном коде)

 If Len(Dir("c:\TOTN\Excel\Examples", vbDirectory)) = 0 Then
   MkDir "c:\TOTN\Excel\Examples"
Конец, если

http://www. techonthenet.com/excel/formulas/mkdir.php

1

Для тех, кто ищет кроссплатформенный способ, который работает как на Windows, так и на Mac, работает следующее:

 Sub CreateDir(strPath As String)
    Тусклый вяз Как вариант
    Dim strCheckPath как строка
    стрчеккпас = ""
    Для каждого вяза в Split(strPath, Application.PathSeparator)
        strCheckPath = strCheckPath & вяз & Application.PathSeparator
        Если (Len(strCheckPath) > 1 и не существует FolderExists(strCheckPath)) тогда
            MkDir strCheckPath
        Конец, если
    Следующий
Конец сабвуфера
Функция FolderExists (FolderPath As String) As Boolean
     Папкасуществует = Истина
     При ошибке Возобновить Далее
     Путь к папке ChDir
     Если Err <> 0, то FolderExists = False
     При ошибке Перейти к 0
Конечная функция

Никогда не пробовал с системами, отличными от Windows, но вот тот, что есть в моей библиотеке, довольно простой в использовании. Не требуется специальной ссылки на библиотеку.

 Функция CreateFolder (ByVal sPath As String) As Boolean
'Патрик Онорес - www.idevlop.com
'создать сразу полный sPath, если требуется
'возвращает False, если папка не существует и НЕ может быть создана, иначе True
пример использования: If CreateFolder("C:\toto\test\test") Then debug.print "OK"
'обновлен 20130422 для правильной обработки путей UNC ("\\MyServer\MyShare\MyFolder")
    Dim fs как объект
    Dim FolderArray
    Папка Dim как строка, i как целое число, sShare как строка
    Если Right(sPath, 1) = "\", тогда sPath = Left(sPath, Len(sPath) - 1)
    Установите fs = CreateObject("Scripting.FileSystemObject")
    'UNC-путь? заменить 3 "\" на 3 "@"
    Если sPath Как "\\*\*" Тогда
        sPath = Заменить(sPath, "\", "@", 1, 3)
    Конец, если
    'теперь разделен
    FolderArray = Разделить (sPath, "\")
    'затем верните @ в \ в элементе 0 массива
    FolderArray(0) = Заменить(FolderArray(0), "@", "\", 1, 3)
    При ошибке иди к черту
    'начать от корня до конца, создавая то, что должно быть
    Для i = 0 To UBound (FolderArray) Шаг 1
        Папка = Папка и Массив Папок (i) и "\"
        Если Не fs. FolderExists(Папка) Тогда
            fs.CreateFolder (Папка)
        Конец, если
    Следующий
    Создать папку = Истина
ад:
Конечная функция

Вот короткая подпрограмма без обработки ошибок, которая создает подкаталоги:

 Открытая функция CreateSubDirs (ByVal vstrPath As String)
   Dim marrPath() как строка
   Dim Mint As Integer
   marrPath = Разделить (vstrPath, "\")
   vstrPath = marrPath(0) & "\"
   For mint = 1 To UBound(marrPath) 'идти вниз по дереву каталогов до тех пор, пока не будет существовать
      Если (Dir(vstrPath, vbDirectory) = ""), то выход для
      vstrPath = vstrPath & marrPath (мятный) & "\"
   Следующий монетный двор
   MkDir vstrPath
   For mint = mint To UBound(marrPath) 'создать каталоги
      vstrPath = vstrPath & marrPath (мятный) & "\"
      MkDir vstrPath
   Следующий монетный двор
Конечная функция

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

Следующий код обрабатывает как пути к диску (например, «C:\Users…»), так и к адресу сервера (стиль: «\Server\Path..»), он принимает путь в качестве аргумента и автоматически удаляет из него любые имена файлов (используйте «\» в конце, если это уже путь к каталогу) и возвращает false, если по какой-либо причине папка не может быть создана. Ах да, он также создает под-под-под-подкаталоги, если это было запрошено.

 Открытая функция CreatePathTo (путь как строка) как логическое значение
Dim sect() As String 'разделы пути
Dim Reserve As Integer ' количество участков пути, которые следует оставить нетронутыми.
Dim cPath As String ' временный путь
Dim pos As Integer 'позиция в пути
Dim lastDir As Integer ' последняя допустимая длина пути
Dim i As Integer ' переменная цикла
' если все работает нормально, предположим, что это не сработало:
СоздатьПатто = Ложь
' обрезать любое имя файла и разделитель пути в конце:
путь = левый (путь, InStrRev (путь, Application.PathSeparator) - 1)
' разбить путь на имена каталогов
секта = Разделить (путь, "\")
'Что это за путь?
If (UBound(sect) < 2) Then 'недопустимый путь
    Выход из функции
ElseIf (InStr(sect(0), ":") = 2) Тогда
    резерв = 0 'зарезервировано только имя диска
ElseIf (sect(0) = vbNullString) И (sect(1) = vbNullString) Тогда
    резерв = 2 ' путь к серверу - резерв "\\Сервер\"
Еще ' неизвестный тип
    Выход из функции
Конец, если
' проверить назад, откуда путь отсутствует:
последний каталог = -1
Для pos = UBound(sect) Зарезервировать Шаг -1
    ' построить путь:
    cPath = vbNullString
    Для i = 0 до поз. 
        cPath = cPath & sect(i) & Application.PathSeparator
    Далее ' я
    ' проверяем, существует ли этот путь:
    Если (Каталог(cPath, vbDirectory) <> vbNullString) Тогда
        последний каталог = позиция
        Выход для
    Конец, если
Следующая поз.
' создать подкаталоги с этого момента и далее:
При ошибке Перейти к ошибке 01
Для pos = lastDir + 1 To UBound(sect)
    ' построить путь:
    cPath = vbNullString
    Для i = 0 до поз.
        cPath = cPath & sect(i) & Application.PathSeparator
    Далее ' я
    ' создаем каталог:
    MkDir cPath
Следующая поз.
CreatePathTo = Истина
Выход из функции
Ошибка01:
Конечная функция

Надеюсь, кому-то это будет полезно. Наслаждаться! 🙂

Это рекурсивная версия, которая работает как с буквенными дисками, так и с UNC. Я использовал перехват ошибок, чтобы реализовать его, но если кто-то может обойтись без него, мне было бы интересно это увидеть. Этот подход работает от ветвей к корню, поэтому его можно использовать, когда у вас нет разрешений в корневой и нижней частях дерева каталогов.

 ' Обратный путь создания каталога. Это создаст дерево каталогов сверху вниз к корню.
' Полезно при работе с сетевыми дисками, где у вас может не быть доступа к каталогам, близким к корню.
Sub RevCreateDir (strCheckPath как строка)
    При ошибке GoTo goUpOneDir:
    Если Len(Dir(strCheckPath, vbDirectory)) = 0 И Len(strCheckPath) > 2 Тогда
        MkDir strCheckPath
    Конец, если
    Выйти из подпрограммы
' Идти вверх по дереву, только если путь с кодом ошибки не найден (76).
goUpOneDir:
    Если Число Ошибок = 76 Тогда
        Вызов RevCreateDir(Left(strCheckPath, InStrRev(strCheckPath, "\") - 1))
        Вызов RevCreateDir (strCheckPath)
    Конец, если
Конец сабвуфера

1

 Создание подпапки()
    MkDir "C:\Test"
Конец сабвуфера

1

 Sub MakeAllPath (ByVal PS$)
    Дим ПП$
    Если ПС <> "" Тогда
        ' отрезать любое конечное имя
        PP = Left(PS, InStrRev(PS, "\") - 1)
        'если нет, так постройте
        Если Dir(PP, vbDirectory) = "" Тогда
            MakeAllPath Left(PP, InStrRev(PS, "\") - 1)
            'если обратно не гонять то строить на том что есть
            Если Right(PP, 1) <> ":" Тогда MkDir PP
        Конец, если
    Конец, если
Конец сабвуфера
'Версия цикла Мартинса выше лучше, чем МОЯ рекурсивная версия
так что улучшите ниже
Sub MakeAllDir (PathS$)
  ' в формате "K:\firstfold\secf\fold3"
  Если Dir(PathS) = vbNullString Тогда
 ' иначе не заморачивайся
   Dim LI&, MYPath$, BuildPath$, PathStrArray$()
   PathStrArray = Разделить (ПутьS, "\")
      BuildPath = PathStrArray(0) & "\" '
      Если Dir(BuildPath) = vbNullString Тогда
'проблема ловушки отсутствия диска :\ указан путь
         Если vbYes = MsgBox(PathStrArray(0) & "< не существует для >" & PathS & " попробуйте добавить к " & CurDir, vbYesNo) Тогда
            BuildPath = CurDir & "\"
         Еще
            Выйти из подпрограммы
         Конец, если
      Конец, если
      '
      ' пройтись по нужным папкам
      '
      Для LI = 1 в UBound(PathStrArray)
         BuildPath = BuildPath & PathStrArray(LI) & "\"
         Если Dir(BuildPath, vbDirectory) = vbNullString, тогда MkDir BuildPath
      Следующий ЛИ
   Конец, если
 ' уже был там
Конец сабвуфера
' использовать как
'MakeAllDir "K:\bil\joan\Johno"
'MakeAllDir "K:\bil\joan\Fredso"
'MakeAllDir "K:\bil\tom\wattom"
'MakeAllDir "K:\bil\herb\watherb"
'MakeAllDir "K:\bil\herb\Jim"
'MakeAllDir "bil\joan\wat" ' диск по умолчанию

Зарегистрируйтесь или войдите в систему

Зарегистрируйтесь с помощью Google

Зарегистрироваться через Facebook

Зарегистрируйтесь, используя электронную почту и пароль

Опубликовать как гость

Электронная почта

Обязательно, но не отображается

Опубликовать как гость

Электронная почта

Требуется, но не отображается

Excel VBA — Создайте папку с подпапками и дополнительной подпапкой + скопируйте Excel в основную папку

, во-первых, извините, если мой английский не идеален, так как я француз.

Я новичок в этом, и я пытаюсь сделать так, чтобы моя компания работала, чтобы сэкономить время.

Я хотел бы сделать код VBA, который создает папку с 9 подпапками внутри, но сложная часть, я думаю, заключается в том, что внутри этих 9 подпапок мне снова нужны подпапки.

Затем мне нужно автоматически скопировать файл Excel в основную папку с таким же именем

Имя основной папки должно быть основано на 3-х строках Excel «A2» «C2» «B2»

Ниже снимок экрана внутри Основная папка:

У меня есть код, который я нашел в Интернете, который делает некоторые вещи, которые мне нужны, но я не знаю, как это сделать.

Ниже код, который у меня есть:

 Sub CreateDirs()
Dim r As Диапазон
Dim RootFolder как строка
Корневая папка = Диапазон ("K2"). Значение
Диапазон("A2").Выбрать
Для каждого r в диапазоне (Selection, Selection.End (xlDown))
Если Лен(р.Текст) > 0 Тогда
При ошибке Возобновить Далее
MkDir RootFolder & "\" & r.Text
MkDir RootFolder & "\" & r. Text & "\" & Range("L2").Value
MkDir RootFolder & "\" & r.Text & "\" & Range("L3").Value
MkDir RootFolder & "\" & r.Text & "\" & Range("L4").Value
При ошибке Перейти к 0
Конец, если
Следующий р
Конец сабвуфера

в сочетании с этим кодом:

 Sub File_Transfer()
'
Dim src как строка, dst как строка, fl как строка
Dim л до тех пор, пока
'Исходный каталог
'Диапазон("A2").Выбрать
lr = Cells(Rows.Count, "H").End(xlUp).Row
Для X = 2 To lr
источник = Диапазон ("F" & X). Значение
'Каталог назначения
dst = Диапазон ("G" & X). Значение
'Имя файла
fl = Диапазон ("E" & X). Значение
При ошибке Возобновить Далее
'получить идентификатор проекта
FileCopy src & "\" & fl, dst & "\" & fl
Если Err.Number <> 0 Тогда
Конец, если
Следующий X
При ошибке Перейти к 0
Конец сабвуфера

Эти 2 кода будут создавать папки с подпапками и копировать файл Excel в основную папку, но основная папка основана только на одном столбце

с этим кодом, у меня есть этот лист Excel:

У меня есть третий код, который создаст только основную папку, но с моим именем на основе моего 3 столбца:

 Sub ExampleCode()
 Dim strName как строка
 Dim strCode как строка
 Dim strCode1 как строка
 Dim fName как строка
 Dim fPath как строка
 Dim lastRow As Long
 Дим и пока
 Dim ws As рабочий лист
'Где мы будем создавать эти папки?
 fPath = "C:\Users\WBRICET\Documents\TESTVBA"
'Проверка ошибок
 Если Правильно(fPath, 1) <> Application.