Создать иерархию папок из данных электронной таблицы

Question

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

Col1  Col2  Col3 
------ ------ ------ 
Car  Toyota Camry 
Car  Toyota Corolla 
Truck Toyota Tacoma 
Car  Toyota Yaris 
Car  Ford  Focus 
Car  Ford  Fusion 
Truck Ford  F150 

Car 
    Toyota 
     Camry 
     Corolla 
     Yaris 
    Ford 
     Focus 
     Fusion 
Truck 
    Toyota 
     Tacoma 
    Ford 
     F-150 
... 

Единственное предостережение к этому будет то, что у меня есть около 15 столбцов, и некоторые из записи заканчиваются в столбце 3 или 4, и поэтому необходимо создавать только те папки.

Может ли кто-нибудь помочь в этом вопросе? Я не чужд программированию, но я все еще довольно новичок в VBA.

Спасибо!

Answer 1

Sub Tester() 

    Const ROOT_FOLDER = "C:\TEMP\" 
    Dim rng As Range, rw As Range, c As Range 
    Dim sPath As String, tmp As String 

    Set rng = Selection 

    For Each rw In rng.Rows 
     sPath = ROOT_FOLDER 
     For Each c In rw.Cells 
      tmp = Trim(c.Value) 
      If Len(tmp) = 0 Then 
       Exit For 
      Else 
       sPath = sPath & tmp & "\" 
       If Len(Dir(sPath, vbDirectory)) = 0 Then MkDir sPath 
      End If 
     Next c 
    Next rw 
End Sub 

Answer 2

Попробуйте это. Предполагается, что вы начинаете с столбца «A», а также запускаете каталог в C: \ (используя переменную sDir). Просто измените «C: \» на то, что вы хотите, чтобы ваша базовая точка была, если вам нужно.

Option Explicit 

Sub startCreating() 
    Call CreateDirectory(2, 1) 
End Sub 

Sub CreateDirectory(ByVal row As Long, ByVal col As Long, Optional ByRef path As String) 
    If (Len(ActiveSheet.Cells(row, col).Value) <= 0) Then 
     Exit Sub 
    End If 

    Dim sDir As String 

    If (Len(path) <= 0) Then 
     path = ActiveSheet.Cells(row, col).Value 
     sDir = "C:\" & path 
    Else 
     sDir = path & "\" & ActiveSheet.Cells(row, col).Value 
    End If 


    If (FileOrDirExists(sDir) = False) Then 
     MkDir sDir 
    End If 

    If (Len(ActiveSheet.Cells(row, col + 1).Value) <= 0) Then 
     Call CreateDirectory(row + 1, 1) 
    Else 
     Call CreateDirectory(row, col + 1, sDir) 
    End If 
End Sub 


' Function thanks to: http://www.vbaexpress.com/kb/getarticle.php?kb_id=559 
Function FileOrDirExists(PathName As String) As Boolean 
    'Macro Purpose: Function returns TRUE if the specified file 
    '    or folder exists, false if not. 
    'PathName  : Supports Windows mapped drives or UNC 
    '    : Supports Macintosh paths 
    'File usage : Provide full file path and extension 
    'Folder usage : Provide full folder path 
    '    Accepts with/without trailing "\" (Windows) 
    '    Accepts with/without trailing ":" (Macintosh) 

    Dim iTemp As Integer 

    'Ignore errors to allow for error evaluation 
    On Error Resume Next 
    iTemp = GetAttr(PathName) 

    'Check if error exists and set response appropriately 
    Select Case Err.Number 
    Case Is = 0 
     FileOrDirExists = True 
    Case Else 
     FileOrDirExists = False 
    End Select 

    'Resume error checking 
    On Error GoTo 0 
End Function 

Answer 3

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

If Dir(YourPath, vbDirectory) = "" Then 
    Shell ("cmd /c mkdir """ & YourPath & """") 
End If