使用VBA在excel列表的所有子目錄文件夾中創建相同的多個文件夾

Question

我目前正試圖設置一個目錄，並試圖從excel電子表格中創建一個目錄。

• Column A工作表列出了所需的文件夾名稱。

• 這是我想讓最終目錄看起來像的一個例子。

  1. VIC \分支1 \文件夾A
  2. VIC \分支1 \文件夾B
  3. VIC \分支2 \文件夾中的
  4. VIC \分支2 \文件夾B 等

我已經能夠創建狀態和分支級別的文件夾，但我堅持在每個分支文件夾中創建相同的五個文件夾。如果任何人都可以幫助VB代碼創建這些文件夾，它將不勝感激。

下面是我用來創建每個州級目錄的分支文件夾的代碼。我跑了每個國家名單，只是改變了目錄位置

謝謝

Sub MakeFolders() 
Dim xdir As String 
Dim fso 
Dim lstrow As Long 
Dim i As Long 
Set fso = CreateObject("Scripting.FileSystemObject") 
lstrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row 
Application.ScreenUpdating = False 
For i = 1 To lstrow 
xdir = "C:\Users\Nikki\Shared\VIC\" & Range("A" & i).Value 
If Not fso.FolderExists(xdir) Then 
fso.CreateFolder (xdir) 
End If 
Next 
Application.ScreenUpdating = True 
End Sub 

Answer 1

使用的子文件夾的數組和循環通過爲每個1級文件夾。

改變這一行
vSubfolders = Array("A", "B", "C") 添加/刪除你的第二個級別的文件夾

Sub MakeFolders() 
Dim xdir As String 
Dim fso As Object 
Dim lstrow As Long 
Dim i As Long 
Dim vSubfolders 
Dim vSubFolder 

vSubfolders = Array("A", "B", "C") 
Set fso = CreateObject("Scripting.FileSystemObject") 
lstrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row 
Application.ScreenUpdating = False 
For i = 1 To lstrow 
xdir = "C:\Users\Nikki\Shared\VIC\" & Range("A" & i).Value 
If Not fso.FolderExists(xdir) Then 
fso.CreateFolder (xdir) 
End If 
For Each vSubFolder In vSubfolders 
If Not fso.FolderExists(xdir & "\" & vSubFolder) Then 
fso.CreateFolder (xdir & "\" & vSubFolder) 
End If 
Next 
Next 
Application.ScreenUpdating = True 
End Sub