创建文件夹、子文件夹、另一个子文件夹并根据单元格值保存自定义文件名 vba

Creating folders, subfolder, another subfolder and saving custom file name based on cell value vba

我正在尝试检查路径中的文件夹 1、2 和 3 是否存在。

例如:C:\Users\%USERNAME%\Documents\Folder 1\Folder 2\Folder 3\

如果它们不存在,它应该创建每个文件夹,然后将工作簿保存在文件夹 3 中。 所有文件夹名称和文件名称都取决于单元格值。

不确定我做错了什么。

     Sub Macro1()
Dim folderPath As String
Dim individualFolders() As String
Dim tempFolderPath As String
Dim arrayElement As Variant

folderPath = "C:\Users\%USERNAME%\Documents" & "\" & Worksheets("Sheet1").Range("A10").Value & "\" & Worksheets("Sheet1").Range("B10").Value & "\" & Worksheets("Sheet1").Range("C10").Value

individualFolders = Split(folderPath, "\")

For Each arrayElement In individualFolders

    tempFolderPath = tempFolderPath & arrayElement & "\"

    If Dir(tempFolderPath, vbDirectory) = "" Then

        MkDir tempFolderPath

     End If

Next arrayElement

strFilename = Worksheets("Sheet1").Range("C1").Value 'New file name
strDefpath = Environ("USERPROFILE") & "\Documents\" & Worksheets("Sheet1").Range("A10").Value & "\" & Worksheets("Sheet1").Range("B10").Value & "\" & Worksheets("Sheet1").Range("C10").Value
If IsEmpty(strDirname) Then Exit Sub
If IsEmpty(strFilename) Then Exit Sub

MkDir strDefpath & "\" & strDirname
strPathname = strDefpath & "\" & strDirname & "\" & strFilename 'create total string

    Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=strPathname & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

End Sub

您正在混合通常在 cmd 中使用的语法,即命令提示符与 vba

请注意,%USERNAME% 是一个环境变量,它在命令提示符中可用,但在 Excel 中不可用。

但是,可以从 VBA 调用命令提示符,如下所示。

folderpath = Chr(34) & "C:\Users\%USERNAME%\Documents\" & Worksheets("Sheet1").Range("A10").Value & "\" & Worksheets("Sheet1").Range("B10").Value & "\" & Worksheets("Sheet1").Range("C10").Value & Chr(34)
Shell "cmd /k mkdir " & folderpath, vbHide

这应该能够一次性创建所有不存在的文件夹(从单元格 A10 到 C10)!