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作者: 准提部林 時間: 2016-3-27 12:11
Sub TEST()
Dim TTL As Worksheet, i%, T1$, T2$, N%, PH$
On Error Resume Next: Set TTL = Sheets("TOTAL"): On Error GoTo 0
If TTL Is Nothing Then Set TTL = Sheets.Add: TTL.Name = "TOTAL"
TTL.Move Sheets(1): TTL.UsedRange.Clear
PH = ThisWorkbook.Path & "\"
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
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
依圖片所示063027底下會有數個資料夾為原本程式碼所新建出來[attach]23641[/attach]
我必須要再各個資料夾內再去新增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
最後一段改為：
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
