返回列表 上一主題 發帖

[發問] excel vba新增資料夾

[發問] excel vba新增資料夾

我有一個檔案,裡面有數個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

061025.rar (13.5 KB)

  1. Sub TEST()
  2. Dim TTL As Worksheet, i%, T1$, T2$, 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. PH = ThisWorkbook.Path & "\"

  7. For i = 2 To Sheets.Count
  8.     T1 = Sheets(i).[Q3]: T2 = Sheets(i).[C3]
  9.     If T1 Like "######" = False Or T2 = "" Then GoTo 101
  10.     TTL.[A1] = "'" & T1
  11.     If Dir(PH & T1, vbDirectory) = "" Then MkDir PH & T1
  12.    
  13.     T2 = Replace(Replace(Replace(T2, "-(", "("), "  ", "-"), "/", "(") & ") PCS"
  14.     N = N + 1: TTL.Cells(N + 1, 1) = T2
  15.     If Dir(PH & T1 & "\" & T2, vbDirectory) = "" Then MkDir PH & T1 & "\" & T2
  16. 101: Next i
  17. End Sub
複製代碼
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

回復 2# 准提部林


    感謝版主的回覆,可是我還是把它改成以下
因為此EXCEL檔是放在固定一台電腦,我必須要到每台電腦去設定巨集按鈕(新增成各excel的快捷按鈕),再指定其檔案及巨集
擷取1.JPG
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

TOP

本帖最後由 badboy741 於 2016-3-30 06:03 編輯

回復 2# 准提部林


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

依圖片所示063027底下會有數個資料夾為原本程式碼所新建出來
擷取3.JPG
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)

TOP

回復 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. PH = ThisWorkbook.Path & "\" '此路徑自行更改

  7. For i = 2 To Sheets.Count
  8.     T1 = Sheets(i).[Q3]: T2 = Sheets(i).[C3]
  9.     If T1 Like "######" = False Or T2 = "" Then GoTo 101
  10.    
  11.     TTL.[A1] = "'" & T1
  12.     If Dir(PH & T1, vbDirectory) = "" Then MkDir PH & T1
  13.    
  14.     T2 = Replace(Replace(Replace(T2, "-(", "("), "  ", "-"), "/", "(") & ") PCS"
  15.     N = N + 1: TTL.Cells(N + 1, 1) = T2
  16.    
  17.     TT = PH & T1 & "\" & T2
  18.     If Dir(TT, vbDirectory) = "" Then MkDir TT
  19.    
  20.     For Each U In Array("25WL", "篩選重測   PCS")
  21.         If Dir(TT & "\" & U, vbDirectory) = "" Then MkDir TT & "\" & U
  22.     Next
  23.    
  24.     For Each U In Array("Burnin ACC after test 25 L-I-V", "Burnin before test 25 L-I-V")
  25.         If Dir(TT & "\" & U, vbDirectory) = "" Then MkDir TT & "\" & U
  26.         
  27.         V = Split("1,65,129,193,257,321,385,449,513,577,641,705,769", ",")
  28.         For j = 1 To UBound(V)
  29.             T3 = TT & "\" & U & "\" & V(j - 1) & "-" & V(j) - 1
  30.             If Dir(T3, vbDirectory) = "" Then MkDir T3
  31.         Next j
  32.     Next
  33. 101: Next i
  34. End Sub
複製代碼
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

回復 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

aaa.jpg
2016-4-9 02:45




063027.rar (208.7 KB)

TOP

回復 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
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

        靜思自在 : 有多少力量就做多少事,不要心存等待,等待才會落空。
返回列表 上一主題