想知道如何在Excel 2010中使用VBA创建文件夹

Question

I'm a newbie here and really nice to meet you, all. And hope I can get some lessons here and I'll be the helpful as well.

Ok, then, let's proceed the question directly. When I'm working, I should create some folder structures with many sub folders. To do so conveniently, our manager created some vba scripts using VBA in Excel 2010, but he quit now. In most cases, I created the folder structure using the file. And when I do this, I select 'Mobile' or'Monitor' from the dropdown list in the excel sheet, and got the result following.

1_Query

2_File

3_INI

5_Reference

6_TM

7_Log

8_PO

The script for creating the above folder structure is like following.

Dim Fieldname As String

Sub Load_Click()

Dim Y_Field As Integer
Dim B_strPath As String

    If ActiveSheet.Cells(1, 8).Value <> "" Then
    B_strPath = ActiveSheet.Cells(1, 8)
    MkDir (B_strPath & "\1_From_Client")
    MkDir (B_strPath & "\1_From_Client\3_TM")
    MkDir (B_strPath & "\1_From_Client\4_Log")
    MkDir (B_strPath & "\2_To_TR")
    MkDir (B_strPath & "\3_query")
    MkDir (B_strPath & "\4_revised")
    MkDir (B_strPath & "\5_From_TR")
    MkDir (B_strPath & "\6_To_Client")
    MkDir (B_strPath & "\7_TM")
    MkDir (B_strPath & "\8_PO")
    MkDir (B_strPath & "\9_Invoice")

        Worksheets("Make DIR").Activate
        CellV1 = Cells(5, 5).Value

        For X = 3 To 4000
            If Worksheets("Project").Cells(X, 3).Value = CellV1 Then
                cellv = Worksheets("Project").Cells(X, 7).Offset(0, 0).Value
                'MsgBox cellv
                Fieldname = Worksheets("Project").Cells(X, 6).Offset(0, 0).Value
                TTT

            End If

        Next X
        Else
        MsgBox "select folder first"

    End If


End Sub

Sub TTT()
Dim strPath As String
Dim strPath_Division As String
Dim SrceFile
Dim DestFile

 'MsgBox Fieldname
 strPath = ActiveSheet.Cells(1, 8)
 strPath_Division = ActiveSheet.Cells(8, 5)


 MkDir (strPath & "\2_To_TR\" & Fieldname)
 MkDir (strPath & "\2_To_TR\" & Fieldname & "\_Query")
 MkDir (strPath & "\2_To_TR\" & Fieldname & "\2_File")
 MkDir (strPath & "\2_To_TR\" & Fieldname & "\3_INI")
 MkDir (strPath & "\2_To_TR\" & Fieldname & "\5_Reference")
 MkDir (strPath & "\2_To_TR\" & Fieldname & "\6_TM")
 MkDir (strPath & "\2_To_TR\" & Fieldname & "\7_Log")
 MkDir (strPath & "\2_To_TR\" & Fieldname & "\8_PO")
 MkDir (strPath & "\6_To_Client\" & Fieldname)

  If strPath_Division = "Mobile" Then
    MkDir (strPath & "\2_To_TR\" & Fieldname & "\4_Term")
    SrceFile = "D:\_Project\_Term\_Mobile\Mobile_Common_Term_130115_" & Fieldname & ".xlsx"
    DestFile = strPath & "\2_To_TR\" & Fieldname & "\4_Term\Mobile_Common_Term_130115_" & Fieldname & ".xlsx"
    FileCopy SrceFile, DestFile
    Else
    MkDir (strPath & "\2_To_TR\" & Fieldname & "\4_Term")
  End If

But recently, I should rearrange the scripts to add some other folder structures with the 'BOX' from drop down list, like the following.

2_File

8_PO

To do so, I added some scripts by myself, but it doesn't working correctly. The script I added is like following.

Sub BOX()
Dim strPath As String
Dim strPath_Division As String
Dim SrceFile
Dim DestFile

 'MsgBox Fieldname
 strPath = ActiveSheet.Cells(1, 8)
 strPath_Division = ActiveSheet.Cells(8, 5)

 If strPath_Division = "BOX" Then
   MkDir (strPath & "\2_To_TR\" & Fieldname)
   MkDir (strPath & "\2_To_TR\" & Fieldname & "\2_File")
   MkDir (strPath & "\2_To_TR\" & Fieldname & "\8_PO")
   MkDir (strPath & "\6_To_Client\" & Fieldname)
 End If


End Sub

Well, as I don't have any reps here, I just copy and paste the script here. And hope it won't cause any inconveniences to you and hope I can take great lessons from all of you.

I do appreciate in advance for your understanding and adivse.

Answer 1

Not sure if this is what you asked but I cleaned it up a bit, and made it easier to add more sub-folders:

Option Explicit

Dim fieldName As String

Sub makeForders()
    Dim i As Long, wsDir As Worksheet, wsPrj As Worksheet, mainPath As String

    Set wsDir = Worksheets("Make DIR")
    Set wsPrj = Worksheets("Project")
    If Len(ActiveSheet.Cells(1, 8).Value) > 0 Then
        mainPath = ActiveSheet.Cells(1, 8)
        If Len(Dir(mainPath & "1_From_Client", vbDirectory)) = 0 Then
            MkDir mainPath & "1_From_Client"
            MkDir mainPath & "1_From_Client\3_TM"
            MkDir mainPath & "1_From_Client\4_Log"
            MkDir mainPath & "2_To_TR"
            MkDir mainPath & "3_query"
            MkDir mainPath & "4_revised"
            MkDir mainPath & "5_From_TR"
            MkDir mainPath & "6_To_Client"
            MkDir mainPath & "7_TM"
            MkDir mainPath & "8_PO"
            MkDir mainPath & "9_Invoice"
        End If
        For i = 3 To 4000
            If wsPrj.Cells(i, 3).Value = wsDir.Cells(5, 5).Value Then
                makeSubForders wsPrj.Cells(i, 6).Value
            End If
        Next
    Else
        MsgBox "Select folder first"
    End If
End Sub

---

Sub makeSubForders(ByVal fieldName As String)
    Const MDL       As String = "\2_To_TR\"
    Const D_PATH    As String = "D:\_Project\_Term\_Mobile\Mobile_Common_Term_130115_"
    Const TERMS     As String = "4_Term\Mobile_Common_Term_130115_"
    Const EXT       As String = ".xlsx"
    Dim pathIni As String, pathDiv As String
    Dim srceFile As String, destFile As String, mainPath As String
    mainPath = ActiveSheet.Cells(1, 8).Value2
    If Len(Dir(mainPath, vbDirectory)) = 0 Then
        MkDir mainPath: MkDir mainPath & "\" & MDL
    End If
    pathIni = mainPath & MDL & fieldName
    If Len(Dir(pathIni, vbDirectory)) = 0 Then
        MkDir pathIni: pathIni = pathIni & "\"
        MkDir pathIni & "_Query"
        MkDir pathIni & "2_File"
        MkDir pathIni & "3_INI"
        MkDir pathIni & "4_Term"
        MkDir pathIni & "5_Reference"
        MkDir pathIni & "6_TM"
        MkDir pathIni & "7_Log"
        MkDir pathIni & "8_PO"
        MkDir pathIni & "6_To_Client\"
        MkDir pathIni & "6_To_Client\" & fieldName
    End If
    pathDiv = ActiveSheet.Cells(8, 5).Value     '"Mobile" or "BOX"
    Select Case pathDiv
        Case "Mobile"
            If Len(Dir(pathIni & "\Mobile_Path", vbDirectory)) = 0 Then
                MkDir pathIni & "\Mobile_Path"
            End If
        Case "BOX"
            If Len(Dir(pathIni & "\BOX_Path", vbDirectory)) = 0 Then
                MkDir pathIni & "\BOX_Path"
            End If
    End Select
End Sub