☰

根据 Excel 单元格值创建文件夹和子文件夹

tag-icon • tag-icon microsoft-excel microsoft-excel-2010 vba
根据 Excel 单元格值创建文件夹和子文件夹

E我正在尝试创建一个名为目录 ( ) 中的列值的目录，然后创建一个名为列、、和c:/Site Information的连接值的另一个目录。此值在我的工作表的列中创建。ABCDH

创建的目录C:/Site Information/value column E/Column H将是结果。

然后我一直尝试在列中创建指向B该文件夹的超链接，并确保每次向后续行添加新记录时都会发生这种情况。

我是 VBS 新手，想知道这是否可行。此外，如果目录“ value column E”已经存在，我需要在此现有目录中创建子目录。

任何帮助，将不胜感激。

这就是我有限的宏技能所能达到的极限。

Sub Create_Folders()

'Parent folder.
ParentFolder = "C:\Site Information"
'Create the folders from selected cells
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count

For c = 1 To maxCols
    r = 1
    Do While r <= maxRows
        If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
            MkDir (ParentFolder & "\" & Rng(r, c))

            On Error Resume Next
        End If
        r = r + 1
    Loop

Next c
End Sub

这会在我的父文件夹中创建文件夹。到目前为止就这些。

我现在尝试通过将必填字段移动到新工作表并连接必填字段来简化任务。

然后我运行以下 VBA

Private Sub CommandButton1_Click()
    For Each objRow In UsedRange.Rows
        strFolders = "C:\Site Information"
        For Each objCell In objRow.Cells
            strFolders = strFolders & "\" & objCell
            Shell ("cmd /c md " & Chr(34) & strFolders & Chr(34))
        Next
        Dim FSO As Object
        Dim FromPath As String
        Dim ToPath As String
        FromPath = "C:\Server Filing"  'predifined folders
        ToPath = strFolders     '<< created sub directory
        If FSO.FolderExists(FromPath) = False Then
            MsgBox FromPath & " doesn't exist"
            Exit Sub
        End If
        FSO.CopyFolder Source:=FromPath, Destination:=ToPath
    Next
End Sub

当我运行它时，它会沿着工作表向下创建以第 1 列命名的目录，然后在其中创建以第 2 列命名的子文件夹。

然后我尝试将一组预定义的文件夹复制到该文件夹​​中。

停止于 FSO.CopyFolder Source:=FromPath, Destination:=ToPath 和未找到路径但在调试时路径仍然存在。

需要克服这个障碍然后尝试自动创建超链接。

有任何想法吗？

如果有人有兴趣，可以在循环中暂停一下，让 cmd 有时间复制文件夹，从而解决找不到路径的问题。

Private Sub Createfolders_Click()
Sheets("Create Folders").Select
For Each objRow In UsedRange.Rows
    strFolders = "C:\Site Information"
    For Each objcell In objRow.Cells
        strFolders = strFolders & "\" & objcell
        Shell ("cmd /c md " & Chr(34) & strFolders & Chr(34))
    Next
    Dim FSO As Object
    Set FSO = CreateObject("scripting.filesystemobject")
    Dim FromPath As String
    Dim ToPath As String
    FromPath = "C:\Server Filing"  '------ Folder were pre defined folders are
    ToPath = strFolders     '<< Change------ Created sub folder
    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If
    If ToPath = "C:\Site Information\\" Then
        MsgBox "Finished"
        Exit Sub
    End If
    If FSO.FolderExists(ToPath) = False Then
        Application.Wait (Now + #12:00:01 AM#)
        FSO.CopyFolder Source:=FromPath, Destination:=ToPath
    End If
Next
End Sub

现在只想生成每个文件夹的超链接。这让我很为难。

答案1

检查这些链接https://msdn.microsoft.com/en-us/library/aa242706%28v=vs.60%29.aspx https://msdn.microsoft.com/en-us/library/office/ff840672.aspx

我想这会对你有帮助。

相关内容