时间戳

首页 > 解决方案 > 将文件保存到目录和子目录

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

问题描述

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

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

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

标签： vbadirectorysavesubdirectory

解决方案

如果你能得到一个你想保存的目录，作为一个字符串，你可以使用下面的两个：

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 and subFolder in 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

推荐阅读