Question

我想创建一个目录并使用代码基于excel中的单元格值保存电子表格。我只能在文件夹级别上执行此操作，如何将代码写成两个级别？公司文件夹在单元格D1中，单元格J2在第二个文件夹中，单元格F2在excel文件中。这是我正在使用的仅适用于一个级别的代码：

 Const MYPATH As String = "R:\Sales\Quotes (Commercial)\"

    Sub IfNewFolder()

    'Dim part1 As String 'this variable is not used -----
    Dim part3 As String  'Company Name
    Dim part4 As String 'Folder Name
    '----- Dim FolderCreate As String  'this variable is not used -----

    '----- part1 = Range("E4").Value 'not used here -----
    part3 = Range("D1").Value
    part4 = Range("J2").Value

    If Len(Dir(MYPATH & part3 & part4, vbDirectory)) = 0 Then
       MkDir MYPATH & part3 & part4
    End If

    End Sub
    Sub SaveFileFolder()

    Dim part1 As String
    Dim part3 As String
    Dim part4 As String

    part1 = Range("F2").Value 'Quote Number
    part3 = Range("D1").Value 'Company Name
    part4 = Range("J2").Value 'Folder Name


    IfNewFolder 'create company subfolder

    'ChDir MYPATH ' From what I've read on the internet, this is telling excel to save files to this directory...
    '-----you don't have to do that because this path is included in the filename in the SaveAs below -----

    ' Creates file to directory Customers. But I can't get it to recognize the new folder created in the sub above...

    'ActiveWorkbook.SaveAs Filename:= _
     MYPATH & part1 & "_" & part3 & ".xlsm", FileFormat:= _
     xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

    '----- instead put company in path (point to company subfolder) -----
    ActiveWorkbook.SaveAs FileName:= _
    MYPATH & part3 & part4 & "\" & part1 & ".xlsm", FileFormat:= _
    xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False


    End Sub
    Sub SaveForm()
    Static Path As String
    Static FileName As String


    If Len(Path) = 0 Then
      Path = Range("J2")
      If Right(Path, 1) <> "\" Then
        'make sure the path is "\" terminated
        Path = Path & "\"
      End If
    Else
      FileName = Range("F2")

     'Application.ScreenUpdating = False
      Application.DisplayAlerts = False
      ActiveSheet.Copy   'not sure why you're doing this, but do so if it makes sense elsewhere in your code
      With ActiveWorkbook.ActiveSheet
        .Range("42:" & Rows.Count).EntireRow.Delete xlShiftDown
        .Range(.Cells(1, "J"), .Cells(1, Columns.Count)).EntireColumn.Delete xlToRight
        .Parent.SaveAs "R:\Sales\Quotes (Commercial)\ExtractedWorksheet\" & _
                       Range("J2") & "\" & FileName & ".xlsx"
        .Parent.Close False
      End With
      Path = ""
      FileName = ""

    End If
    End Sub

感谢您的帮助。

Lamar

Answer 1

好吧，我重新编写了代码并使它正常工作，但我仍然希望我们使用单元格J2来制作文件夹2018，以便当年份临近时，我可以更改销售日期，而不必输入代码改变它。这是我的更新代码：

Sub IfNewFolder()
Dim r As Range
Dim RootFolder As String
RootFolder = "R:\Sales\Quotes (Commercial)\" '<<< CHANGE 1
For Each r In Range("D1") '<<< CHANGE 2
If Len(r.Text) > 0 Then
On Error Resume Next
MkDir RootFolder & "\" & r.Text
   MkDir RootFolder & "\" & r.Text & ("\2018")
     On Error GoTo 0
     End If
    Next r  
     End Sub

如何删除（MkDir RootFolder和“ \”＆r.Text和（“ \ 2018”）），使其指向单元格J2

谢谢

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

1 个答案: