Question

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

此代码用于 checking/creating 第一个目录并在其中保存文件。

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 中创建 MyFolder 和 subFolder：

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

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

Saving files to directory and subdirectory

directory

vba

save

subdirectory