[發問] excel vba新增資料夾 新增, 新資料夾 命名, vba, 建立, excel

badboy741

我有一個檔案，裡面有數個sheet，需要以各個sheet內的C3為命名建立數個資料夾，再把它們全部丟入以Q3為命名的資料夾內，我剪剪貼貼後得到了我要的效果，可是它們全部都丟在桌面，並沒有全部都都入以Q3為名的資料夾內


Sub LL()
    Sheets.Add
    Sheets("Sheet1").Name = "TOTAL"
    Sheets("TOTAL").Move Before:=Sheets(1)
Dim i, j As String
Dim sh As String
    i = 1                                                                                                     'total sheet 從第二列開始
For n = 1 To ActiveWorkbook.Sheets.Count                                '總共有幾張sheet
    sh = "N"                                                                                             '工作表名稱
    Worksheets(n).Select                                                                     '選擇某頁工作表
    Value1 = Range("C3").Value                                                        '需彙總的儲存格值分別放入各個變數
    Worksheets("TOTAL").Select                                                       '選擇TOTAL  sheet
    Range("A" & i).Value = Value1                                                   '將各個變數值分別放入儲存格位置
    i = i + 1                                                                                             '彙總頁total往下新增一列 N頁明細表就有N列資料
Next
    Cells.Replace What:=" ", Replacement:="-", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:="--", Replacement:="-", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:="/", Replacement:="(", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:="-(", Replacement:="(", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
For i = 2 To n - 1
    Range("A" & i).Value = Range("A" & i).Value & ")  PCS"
Next
    Cells.Replace What:="-)", Replacement:=")", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Sheets("1").Select
        Range("Q3").Copy
    Sheets("TOTAL").Select
        Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Dim strPath, strFolderName
Dim objFS, objFloder, objFC
    strPath = "C:\Users\tod210\Desktop\"
    strFolderName = Range("A1").Value
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strPath)
Set objFC = objFolder.SubFolders
    objFC.Add (strFolderName)

Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim folder As String
    folder = ThisWorkbook.Path & "\"
Dim NX As Long, X As Long, NM As String
    NX = [A65536].End(xlUp).Row
For X = 2 To NX
    NM = Cells(X, 1).Value
If NM = "" Then GoTo nextname
    FSO.CreateFolder (folder & NM)
nextname:
Next
End Sub

准提部林

1. Sub TEST()
   
2. Dim TTL As Worksheet, i%, T1$, T2$, N%, PH$
   
3. 
   
4. On Error Resume Next: Set TTL = Sheets("TOTAL"): On Error GoTo 0
   
5. If TTL Is Nothing Then Set TTL = Sheets.Add: TTL.Name = "TOTAL"
   
6. TTL.Move Sheets(1): TTL.UsedRange.Clear
   
7. 
   
8. PH = ThisWorkbook.Path & "\"
   
9. 
   
10. For i = 2 To Sheets.Count
    
11.     T1 = Sheets(i).[Q3]: T2 = Sheets(i).[C3]
    
12.     If T1 Like "######" = False Or T2 = "" Then GoTo 101
    
13.     TTL.[A1] = "'" & T1
    
14.     If Dir(PH & T1, vbDirectory) = "" Then MkDir PH & T1
    
15.    
    
16.     T2 = Replace(Replace(Replace(T2, "-(", "("), "  ", "-"), "/", "(") & ") PCS"
    
17.     N = N + 1: TTL.Cells(N + 1, 1) = T2
    
18.     If Dir(PH & T1 & "\" & T2, vbDirectory) = "" Then MkDir PH & T1 & "\" & T2
    
19. 101: Next i
    
20. End Sub

複製代碼

badboy741

回復 2# 准提部林


    感謝版主的回覆，可是我還是把它改成以下
因為此EXCEL檔是放在固定一台電腦，我必須要到每台電腦去設定巨集按鈕(新增成各excel的快捷按鈕)，再指定其檔案及巨集

下載 (55.08 KB)

2016-3-28 20:25

原始檔無法修改，照您的設定它會再本身的workbook去增加sheet，這樣一來它會抓到空白的workbook去新增資料夾，也就不會跑任何東西出來了


Sub LL()
    Sheets.Add
    Sheets("Sheet1").Name = "TOTAL"
    Sheets("TOTAL").Move Before:=Sheets(1)

Dim TTL As Worksheet, i%, T1$, T2$, N%, PH$
On Error Resume Next: Set TTL = Sheets("TOTAL"): On Error GoTo 0

PH = "C:\Users\tod210\Desktop\"

For i = 2 To Sheets.Count
    T1 = Sheets(i).[Q3]: T2 = Sheets(i).[C3]
    If T1 Like "######" = False Or T2 = "" Then GoTo 101
    TTL.[A1] = "'" & T1
    If Dir(PH & T1, vbDirectory) = "" Then MkDir PH & T1
   
    T2 = Replace(Replace(Replace(T2, "-(", "("), "  ", "-"), "/", "(") & ") PCS"
    N = N + 1: TTL.Cells(N + 1, 1) = T2
    If Dir(PH & T1 & "\" & T2, vbDirectory) = "" Then MkDir PH & T1 & "\" & T2
101: Next i

ActiveWorkbook.Close False
Application.Quit

End Sub

badboy741

回復 2# 准提部林


    請問我依照excel建立出來的資料夾底下有一層，vba還可以再底下多新建立指定檔名的資料夾嗎？

依圖片所示063027底下會有數個資料夾為原本程式碼所新建出來

下載 (68.9 KB)

2016-3-30 06:00

我必須要再各個資料夾內再去新增4個檔名為固定的資料夾
分別為
25WL
Burnin before test 25 L-I-V
Burnin after test 25 L-I-V
篩選重測
這其中"Burnin before test 25 L-I-V"、"Burnin after test 25 L-I-V"底下各必須有12個固定檔名的空資料夾
1-64
65-128
129-192
193-256
257-320
321-384
385-448
449-512
513-576
577-640
641-704
705-768

詳細結果如附件
063027.rar (18.4 KB)

下載次數: 3

2016-3-30 06:03

准提部林

回復 4# badboy741

1. Sub TEST()
   
2. Dim TTL As Worksheet, i%, j%, T1$, T2$, T3$, TT$, U, V, N%, PH$
   
3. On Error Resume Next: Set TTL = Sheets("TOTAL"): On Error GoTo 0
   
4. If TTL Is Nothing Then Set TTL = Sheets.Add: TTL.Name = "TOTAL"
   
5. TTL.Move Sheets(1): TTL.UsedRange.Clear
   
6. 
   
7. PH = ThisWorkbook.Path & "\" '此路徑自行更改
   
8. 
   
9. For i = 2 To Sheets.Count
   
10.     T1 = Sheets(i).[Q3]: T2 = Sheets(i).[C3]
    
11.     If T1 Like "######" = False Or T2 = "" Then GoTo 101
    
12.    
    
13.     TTL.[A1] = "'" & T1
    
14.     If Dir(PH & T1, vbDirectory) = "" Then MkDir PH & T1
    
15.    
    
16.     T2 = Replace(Replace(Replace(T2, "-(", "("), "  ", "-"), "/", "(") & ") PCS"
    
17.     N = N + 1: TTL.Cells(N + 1, 1) = T2
    
18.    
    
19.     TT = PH & T1 & "\" & T2
    
20.     If Dir(TT, vbDirectory) = "" Then MkDir TT
    
21.    
    
22.     For Each U In Array("25WL", "篩選重測   PCS")
    
23.         If Dir(TT & "\" & U, vbDirectory) = "" Then MkDir TT & "\" & U
    
24.     Next
    
25.    
    
26.     For Each U In Array("Burnin ACC after test 25 L-I-V", "Burnin before test 25 L-I-V")
    
27.         If Dir(TT & "\" & U, vbDirectory) = "" Then MkDir TT & "\" & U
    
28.         
    
29.         V = Split("1,65,129,193,257,321,385,449,513,577,641,705,769", ",")
    
30.         For j = 1 To UBound(V)
    
31.             T3 = TT & "\" & U & "\" & V(j - 1) & "-" & V(j) - 1
    
32.             If Dir(T3, vbDirectory) = "" Then MkDir T3
    
33.         Next j
    
34.     Next
    
35. 101: Next i
    
36. End Sub

複製代碼

badboy741

回復 5# 准提部林


    Dear 版大
究上述程式目前可順利使用，但資料夾內1-64,65-128,129-192....所建立資料夾為固定，此程式可否加入變數，讓她自行判斷數量
例如我的sheets("1").range("L7")數量為382，讓它建立到1-64,65-128,129-192,193-256,257-320,321-384
                sheets("2").range("L7")數量為21，讓它建立到1-21，不要每個都建立12個資料夾到768

下載 (69.74 KB)

2016-4-9 02:45

063027.rar (208.7 KB)

下載次數: 3

2016-4-9 02:31

准提部林

回復 6# badboy741


最後一段改為：
    For Each U In Array("Burnin ACC after test 25 L-I-V", "Burnin before test 25 L-I-V")
        If Dir(TT & "\" & U, vbDirectory) = "" Then MkDir TT & "\" & U
        
        X = Val(Sheets(i).[L7])
        For j = 1 To X Step 64
            V = j + 63: If V > X Then V = X
            T3 = TT & "\" & U & "\" & j & "-" & V
            If Dir(T3, vbDirectory) = "" Then MkDir T3
        Next j
    Next