Как создать папки с подпапками из таблицы Excel выделенных ячеек - VBA
Формулировка задачи:
Всем доброго времени суток! У меня вопрос к знающим, как можно создать папки с подпапками из таблицы Exel выделенных ячеек? Например в
столбце А
имена папок, а встолбце B
имена папок принадлежащихстолбцу А
, потом уже выделять значения этих строк и создавать папки(столбец А)
с подпапками(столбец B)
. Всего у меня может быть до 10 столбцов и N-ное количество записей в длину. Нашел пример кода который делает эти операции, ноон не может
работать столько выделенными
значениями ячеек, а только когда выделено все в таблице.Нашел на форуме еще код, который работает с выделенными ячейками
Declare Function MakeSureDirectoryPathExists Lib "Imagehlp.dll" (ByVal strPath As String) As Long
'проверяет наличие папки с указанным путем и создает, если ее нет
'возвращает 0, если папку создать не удалось и не-0, если ОК
Как совместить эти два кода в один работающий макрос?
Пример:Решение задачи: «Как создать папки с подпапками из таблицы Excel выделенных ячеек»
textual
Листинг программы
Sub CreateMultiFolder2() Dim s As String, sF As String, sSF As String Dim arr, k&, i&, j&, Strok&, Stolbcov&, LastBound&, lr As Long, lc As Long Const sMainDir As String = "C:" ' \-исчезает на форуме, Правильно C:\ If Dir(sMainDir, 16) = "" Then MsgBox "Корневая папка '" & sMainDir & "' отсутствует!" Exit Sub End If If Not IsArray(Selection.Value) Then ReDim arr(1 To 1, 1 To 1) arr(1, 1) = Selection.Value Else arr = Selection.Value Strok = UBound(arr) For k = 2 To Selection.Areas.Count LastBound = UBound(arr, 2) Stolbcov = UBound(arr, 2) + Selection.Areas(k).Columns.Count ReDim Preserve arr(1 To Strok, 1 To Stolbcov) For i = 1 To Strok For j = 1 To Selection.Areas(k).Columns.Count arr(i, LastBound + j) = Selection.Areas(k).Cells(i, j) Next j Next i Next End If For lr = 1 To UBound(arr, 1) s = arr(lr, 1) s = Trim(s) If Len(s) Then sF = sMainDir & arr(lr, 1) If Dir(sF, 16) = "" Then MkDir sF End If sSF = sF For lc = 2 To UBound(arr, 2) s = arr(lr, lc) s = Trim(s) If Len(s) Then sSF = sSF & "" & s ' \-исчезает на форуме, Правильно & "\ If Dir(sSF, 16) = "" Then MkDir sSF End If End If Next lc End If Next lr End Sub
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д