Option Explicit
Sub TEST()
Dim Brr, Crr, V, Y, i&, j&, R, T, Td$, Tn$, G1$
Dim xR As Range, xU As Range, Sh As Worksheet, MyBook, MyPath
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = Sheets("裝櫃通知")
Set R = Sh.[D:D].Find("TOTAL", Lookat:=xlWhole)
If Not R Is Nothing Then R = R.Row
Brr = Range(Sh.[A7], Sh.Cells(R - 1, "H"))
For i = 1 To UBound(Brr)
If Brr(i, 1) = "" Then
For j = 1 To 8: T = T & Trim(Brr(i, j)): Next
If T <> "" Then Brr(i, 1) = Brr(i - 1, 1) Else: GoTo i01
End If
Y(Brr(i, 1)) = Y(Brr(i, 1)) + 1
If Y(Brr(i, 1) & "|c") = "" Then Y(Brr(i, 1) & "|c") = Brr(i, 3)
i01: T = "": Next
If Y.Count = 0 Then Exit Sub
G1 = Sh.[G1].Text & Sh.[E1] & "-" & Replace(Replace(Sh.[G2], "/", ""), "#", "") & Sh.[H2]
Td = Format(Now, "YYYY_MM_DD_HH_MM_SS")
Set MyBook = ThisWorkbook
MyPath = MyBook.Path & "\"
If Dir(MyPath & Td, vbDirectory) = "" Then MkDir MyPath & Td
For Each T In Y.KEYS
If InStr(T, "|") Then GoTo i02
Sheets("裝櫃通知").Copy
Set xU = Cells(Rows.Count, 1).Resize(1, 8)
For i = 1 To UBound(Brr)
If Brr(i, 1) <> T Then
Set xU = Union(Cells(i + 6, 1).Resize(1, 8), xU)
End If
Next
xU.Delete: [A7] = 1
Tn = Y(T & "|c") & "-" & G1 & ".xlsx"
ActiveWorkbook.SaveAs Filename:=MyPath & Td & "\" & Tn, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
i02: Next
[A7].Resize(UBound(Brr), 8) = Brr
Set Y = Nothing: Set Sh = Nothing: Erase Brr
End Sub作者: PJChen 時間: 2023-4-26 00:09
Option Explicit
Sub TEST()
Dim Brr, Crr, V, Y, R, T, i&, j&, Td$, Tn$, G1$
Dim xR As Range, xU As Range, Sh As Worksheet, MyBook, MyPath
'↑宣告變數:(Brr,Crr,V,Y,R,T)是通用型變數,(i,j)是長整數,(Td,Tn,G1)是字串變數
',(xR,xU)是儲存格變數,Sh是工作表變數,(MyBook,MyPath)是通用型變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y這通用型變數是 字典
Set Sh = Sheets("裝櫃通知")
'↑令Sh這儲存格變數是 名為"裝櫃通知"的工作表
Set R = Sh.[D:D].Find("TOTAL", Lookat:=xlWhole)
'↑令R這通用型變數是 以Range.Find方法找D欄中儲存格值是全同 "TOTAL"字串
'https://learn.microsoft.com/zh-tw/office/vba/api/excel.range.find
If Not R Is Nothing Then R = R.Row Else Exit Sub
'↑如果R變數找到儲存格!就令R這變數換裝R變數(儲存格)的列號,
'否則就結束程式執行
Brr = Range(Sh.[A7], Sh.Cells(R - 1, "H"))
'↑令Brr這通用型變數是 二維陣列,以[A7]到H欄(R變數-1)列儲存格值帶入
For i = 1 To UBound(Brr)
'↑設順迴圈!i從1到 Brr陣列縱向最大索引列號
If Brr(i, 1) = "" Then
'↑如果i迴圈列第1欄Brr陣列值是 空字元
For j = 1 To 8: T = T & Trim(Brr(i, j)): Next
'↑設順迴圈!j從1到 8,令T這字串變數是自身連接,
'(i迴圈列j迴圈欄Brr陣列值)去除頭尾空白字元後組成的新字串
If T <> "" Then Brr(i, 1) = Brr(i - 1, 1) Else: GoTo i01
'↑如果T變數不是空字元!就令i迴圈列第1欄Brr陣列值是上一列陣列值
'否則就跳到i01標示位置繼續執行
End If
Y(Brr(i, 1)) = Y(Brr(i, 1)) + 1
'↑令i迴圈列第1欄Brr陣列值當key,item是item自身累加1
If Y(Brr(i, 1) & "|c") = "" Then Y(Brr(i, 1) & "|c") = Brr(i, 3)
'↑如果令i迴圈列第1欄Brr陣列值當key查Y字典得item值是 空字元?
'就令令i迴圈列第1欄Brr陣列值連接 "|c"後的新字串當key,item是i迴圈列第3欄Brr陣列值
i01: T = "": Next
If Y.Count = 0 Then Exit Sub
'↑如果Y字典key的個數是 0個!就結束程式執行
G1 = Sh.[G1].Text & Sh.[E1] & "-" & Replace(Replace(Sh.[G2], "/", ""), "#", "") & Sh.[H2]
'↑令G1這字串變數是 [G1]儲存格體現的字轉成文字 連接[E1]儲存格值,連接"-",
'再連接([G2]儲存格去除"/"字元與"#"字元),最後連接[H2]儲存格值
Td = Format(Now, "YYYY_MM_DD_HH_MM_SS")
'↑令Td這字串變數是 現在時間轉成文字
Set MyBook = ThisWorkbook
'↑令MyBook這通用型變數是 本活頁簿
MyPath = MyBook.Path & "\"
'↑令MyPath這通用型變數是 本活頁簿路徑 連接"\"後的新字串
MkDir MyPath & Td
'↑令產生一個資料夾,名字是 TD,路徑在MyPath
For Each T In Y.KEYS
'↑設逐項迴圈!令T變數是 Y字典裡的一個key
If InStr(T, "|") Then GoTo i02
'↑如果T變數裡有包含"|"字元!就跳到i02標示位置繼續執行
Sh.Copy
'↑令Sh變數("裝櫃通知"工作表)複製到新開的活頁簿
Set xU = Cells(Rows.Count, 1).Resize(1, 8)
'↑令xU這儲存格變數是本表A欄最後列儲存格,向右擴展8格範圍的儲存格
For i = 1 To UBound(Brr)
'↑令設順迴圈!i從1到 Brr陣列縱向最大索引列號
If Brr(i, 1) <> T Then
'↑如果i迴圈列第1欄Brr陣列值 與 變數不同?
Set xU = Union(Cells(i + 6, 1).Resize(1, 8), xU)
'↑令xU變數繼續以Union()方法納入不要的儲存格
End If
Next
xU.Delete: [A7] = 1
'↑令xU變數(儲存格)刪除,令[A7]儲存格值是 1
Tn = Y(T & "|c") & "-" & G1 & ".xlsx"
'↑令Tn這字串變數 是組合各必要變數組成的新字串
ActiveWorkbook.SaveAs Filename:=MyPath & Td & "\" & Tn, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'↑令檔案依 指定位置 指定檔名 儲存
ActiveWindow.Close
'↑關閉檔案
i02: Next
Set Y = Nothing: Set Sh = Nothing: Erase Brr
'↑令釋放變數
End Sub作者: 准提部林 時間: 2023-4-27 10:58
