从电子表格数据创建文件夹层次结构答案

【问题标题】：Create folder hierarchy from spreadsheet data从电子表格数据创建文件夹层次结构
【发布时间】：2012-04-23 01:15:21
【问题描述】：

我有几个电子表格，其中的数据从左到右组织，我想从中创建文件夹。每条记录都是完整的，没有空白，除非那是行尾，所以我正在拍摄以下内容：

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 还是很陌生。

谢谢！

【问题讨论】：

标签： excel vba directory hierarchy

【解决方案1】：

试试这个。它假定您从“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

【讨论】：

【解决方案2】：

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

【讨论】：

【解决方案3】：

我发现了一种更好的方法来做同样的事情，代码更少，效率更高。请注意，“”“”是引用路径，以防文件夹名称中包含空格。如有必要，命令行 mkdir 创建任何中间文件夹以使整个路径存在。因此，您所要做的就是使用 \ 作为分隔符来连接单元格以指定您的路径，然后

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

【讨论】：