返回列表 上一主題 發帖

[發問] excel vba新增資料夾

badboy741

帖子
4 
主題
1 
精華
0 
積分
7 
點名
0  
作業系統
windows7 
軟體版本
office2003 
閱讀權限
10 
註冊時間
2016-3-25 
最後登錄
2016-4-9 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2016-3-26 00:05 | 只看該作者

[發問] excel vba新增資料夾

新增, 新資料夾 命名, vba, 建立, excel
我有一個檔案，裡面有數個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)

收藏 分享

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-25 
7#
發表於 2016-4-9 10:10 | 只看該作者
回復 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

TOP

badboy741

帖子
4 
主題
1 
精華
0 
積分
7 
點名
0  
作業系統
windows7 
軟體版本
office2003 
閱讀權限
10 
註冊時間
2016-3-25 
最後登錄
2016-4-9 
6#
發表於 2016-4-9 02:46 | 只看該作者
回復 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





063027.rar (208.7 KB)

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-25 
5#
發表於 2016-3-30 11:57 | 只看該作者
回復 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

  7. PH = ThisWorkbook.Path & "\" '此路徑自行更改

  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
複製代碼

TOP

badboy741

帖子
4 
主題
1 
精華
0 
積分
7 
點名
0  
作業系統
windows7 
軟體版本
office2003 
閱讀權限
10 
註冊時間
2016-3-25 
最後登錄
2016-4-9 
4#
發表於 2016-3-30 06:01 | 只看該作者
本帖最後由 badboy741 於 2016-3-30 06:03 編輯

回復 2# 准提部林


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

依圖片所示063027底下會有數個資料夾為原本程式碼所新建出來
我必須要再各個資料夾內再去新增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

badboy741

帖子
4 
主題
1 
精華
0 
積分
7 
點名
0  
作業系統
windows7 
軟體版本
office2003 
閱讀權限
10 
註冊時間
2016-3-25 
最後登錄
2016-4-9 
3#
發表於 2016-3-28 20:32 | 只看該作者
回復 2# 准提部林


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

原始檔無法修改，照您的設定它會再本身的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

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-25 
2#
發表於 2016-3-27 12:11 | 只看該作者
  1. Sub TEST()
  2. Dim TTL As Worksheet, i%, T1$, T2$, N%, PH$

  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

  8. PH = ThisWorkbook.Path & "\"

  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
複製代碼

TOP

        靜思自在 : 君子為目標，小人為目的。
返回列表 上一主題