返回列表 上一主題 發帖

[發問] excel vba新增資料夾

准提部林

帖子
2839 
主題
10 
精華
0 
積分
2895 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-2-15 
1# 跳轉到 »
發表於 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

准提部林

帖子
2839 
主題
10 
精華
0 
積分
2895 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-2-15 
2#
發表於 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

准提部林

帖子
2839 
主題
10 
精華
0 
積分
2895 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-2-15 
3#
發表於 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

        靜思自在 : 一個人不怕錯，就怕不改過，改過並不難。
返回列表 上一主題