将文件保存到目录和子目录

Question

我正在尝试将基于单元格值的文件保存在基于单元格值的目录和子目录中。代码的目标是检查目录和子目录是否存在，然后在必要时创建文件夹。有人可以向我展示并解释如何更改此代码以创建子目录吗？

此代码用于检查/创建第一个目录并将文件保存在其中。

Sub Macro4()
Dim strFilename, strDirname, strPathname, strDefpath As String
On Error Resume Next ' If directory exist goto next line
strDirname = Worksheets("Private").Range("M2").Value ' New directory name

strFilename = Worksheets("Sheet2").Range("C1").Value 'New file name
strDefpath = Environ("USERPROFILE") & "\Documents\Folder1\" & Worksheets("Private").Range("L2").Value 'Default path name"
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

这是我尝试在初始目录之外创建子目录的方法。

Sub Macro4()
Dim strFilename, strDirname, strDir2name, strPathname, strDefpath As String
On Error Resume Next ' If directory exist goto next line
strDirname = Worksheets("Private").Range("L2").Value 'New directory name
strDir2name = Worksheets("Private").Range("M2").Value ' New directory 2 name

strFilename = Worksheets("Sheet2").Range("C1").Value 'New file name
strDefpath = Environ("USERPROFILE") & "\Documents\Folder1" 'Default path name"
If IsEmpty(strDirname) Then Exit Sub
If IsEmpty(strDir2name) Then Exit Sub
If IsEmpty(strFilename) Then Exit Sub

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

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

End Sub

Answer 1

如果可以将要保存的目录作为字符串保存，则可以使用以下两个：

Sub Test()
Dim myDir as String
myDir = "C:\Users\Beedle\MyFolder\subFolder\"
MyMkDir myDir
' Now you can save/do whatever with myDir.
End Sub

和子，将创建所有必要的文件夹。 （因此，如果您只有C:\Users\Beedle，它将在MyFolder中创建subFolder 和 MyFolder：

Public Sub MyMkDir(sPath As String)
'https://www.devhut.net/2011/09/15/vba-create-directory-structurecreate-multiple-directories/
Dim iStart          As Integer
Dim aDirs           As Variant
Dim sCurDir         As String
Dim i               As Integer

If sPath <> "" Then
    aDirs = Split(sPath, "\")
    If Left(sPath, 2) = "\\" Then
        iStart = 3
    Else
        iStart = 1
    End If

    sCurDir = Left(sPath, InStr(iStart, sPath, "\"))

    For i = iStart To UBound(aDirs)
        sCurDir = sCurDir & aDirs(i) & "\"
        If Dir(sCurDir, vbDirectory) = vbNullString Then
            MkDir sCurDir
        End If
    Next i
End If
End Sub