Create folder hierarchy from spreadsheet data

问题

I have several spreadsheets with data organized from left to right which I would like to create folders from. Every record is complete with no blanks unless that is the end of the row, so I am shooting for something the following:

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
...

The only caveat to this would be that I have about 15 columns, and some of the entries end at column 3 or 4, and so only those folders need to be created.

Can anyone help with this request? I'm no stranger to programming, but I'm still pretty new with VBA.

Thanks!

回答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

回答2:

I found a much better way of doing the same, less code, much more efficient. Note that the """" is to quote the path in case it contains blanks in a folder name. Command line mkdir creates any intermediary folder if necessary to make the whole path exist. So all you have to do is to concatenate the cells using \ as separator to specify your path and then

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

回答3:

Try this out. It assumes you start at column "A" and it also starts the directory in C:\ (using the sDir variable). Just change "C:\" to whatever you want your base point to be if you need to.

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

来源：https://stackoverflow.com/questions/10093983/create-folder-hierarchy-from-spreadsheet-data

标签

excel

vba