Option Explicit
Sub TEST()
Dim Brr, Y, R&, C%, Nr&, Nc%, i&, T1$, T2$, Sh As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = Sheet1: Brr = Sh.[A1].CurrentRegion
ReDim Crr(1 To UBound(Brr), 1 To 200)
For i = 1 To UBound(Brr)
T1 = Brr(i, 1): T2 = Brr(i, 2): T2 = Left(T2, 2) & Format(Mid(T2, 3), "00")
If i = 1 Then: R = R + 1: C = C + 1: Crr(R, 1) = T1 & "\" & T2: GoTo i01
If Y(T1) = "" Then R = R + 1: Y(T1) = R: Crr(R, 1) = T1
If Y(T2) = "" Then C = C + 1: Y(T2) = C: Crr(1, C) = T2
Nr = Y(T1): Nc = Y(T2): Crr(Nr, Nc) = Crr(Nr, Nc) + Brr(i, 3)
i01: Next
Sh.[F1].CurrentRegion.EntireColumn.Clear
With Sh.[F1].Resize(R, C)
.Value = Crr
.Sort Key1:=.Item(1), Order1:=1, Header:=1, Orientation:=1
.Offset(0, 1).Sort Key1:=.Item(1), Order1:=1, Header:=1, Orientation:=2
.Item(R + 1, 1) = "TOTAL": .Item(1, C + 1) = "TOTAL"
.Item(R + 1, 2).Resize(1, C) = "=SUM(G2:G" & R & ")"
.Item(2, C + 1).Resize(R - 1, 1) = "=SUM(RC[" & -C + 1 & "]:RC[-1])"
.EntireColumn.AutoFit
.Borders.LineStyle = 1
End With
With Sh.[F1].CurrentRegion
.Borders.LineStyle = 1
Union(.Rows(1), .Rows(R + 1), .Columns(1), .Columns(C + 1)).Font.Bold = True
End With
Set Y = Nothing: Erase Brr, Crr
End Sub作者: Andy2483 時間: 2023-5-5 11:57
Sub TEST_A1()
Dim Arr, Brr, xD, xD2, M&, V&, R&, i&, j%, C%, Cn%, T$
'↑宣告變數:(Arr,Brr,xD,xD2)是通用型變數,(M,V,R,i)是長整數,
'(j,C,Cn)是短整數,T是字串變數
Set xD = CreateObject("Scripting.Dictionary")
Set xD2 = CreateObject("Scripting.Dictionary")
'↑各令(xD,xD2)是字典
Arr = Sheet1.[a1].CurrentRegion
'↑令Arr這通用型變數是 二維陣列,以表1的[A1]串並聯後擴展最小方正範圍,
'最小方正範圍儲存格值帶入Arr陣列中
ReDim Brr(1 To UBound(Arr), 1 To 250)
'↑宣告Brr這通用型變數是二維空陣列,縱向範圍:1到Arr陣列最大索引列號,
'橫向範圍從1 到250
For i = 2 To UBound(Arr)
'↑設順迴圈!i從2 到Arr陣列最大索引列號
M = Arr(i, 1): V = Arr(i, 6): T = ""
'↑令M這長整數變數是 i迴圈列第1欄Arr陣列值,
'令V這長整數變數是 i迴圈列第6欄Arr陣列值,令T這字串變數是 空字元
For j = 2 To 5
'↑設順迴圈!j從2 到5
T = T & "|" & Arr(i, j) '|廠別|廠別編號|代號|名稱
'↑令T變數是自身連接"|"符號再連接,
'連接i迴圈列第j迴圈欄Arr陣列值所組成的新字串
Next
If Not xD.Exists(T) Then
'↑如果以T變數查xD字典裡沒有這個key?
Set xD(T) = CreateObject("Scripting.Dictionary")
'↑令以T變數當key,item是字典,納入xD字典裡 (字典中的字典)
R = R + 1
'↑令R這長整數變數 累加1 (PS:R長整數變數的初始值是0)
For j = 1 To 4
'↑設順迴圈!j從1 到4
Brr(R + 1, j) = Arr(i, j + 1)
'↑令(R變數+1)列第j變數欄Brr陣列值是 ,
'是 i迴圈列第(j迴圈+1)欄Arr陣列值
If R = 1 Then Brr(1, j) = Arr(1, j + 1)
'↑如果R變數是 1!就令第1列j迴圈欄Brr陣列值是 ,
'是 第1列第(j變數+1)欄Arr陣列值 (處理標題列)
Next
End If
If M > xD2(T & -1) Then
'↑如果M變數大於 以(T變數連接"-1"所組成新字串)查xD2字典回傳item值
xD2(T & -1) = M '(月日)
'↑令以(T變數連接"-1"所組成新字串)當key,
'item值是 M變數,納入xD2字典
xD2(T) = V '(價格)
'↑令以 T變數當key,item值是 V變數,納入xD2字典
End If
xD(T)(V) = ""
'↑令以 V變數(價格)當key,item是空字元納入 T變數的字典裡
Next i
'-----------------------------------
For i = 1 To R
'↑設順迴圈!i從2 到R變數(子字典的數量)
T = xD.keys()(i - 1)
'↑令T變數是 xD字典裡的第(i變數-1)索引號key
V = xD2(T)
'↑令V變數是 T變數查xD2字典回傳item值(價格)
Brr(i + 1, 5) = V
'↑令(i迴圈+1)列第5欄Brr陣列值是 V變數
xD(T).Remove V
'↑令T變數子字典裡的 V變數key移除
Cn = xD(T).Count
'↑令Cn這短整數變數是 T變數子字典裡key的數量
If Cn > C Then C = Cn
'↑如果Cn變數大於C這短整數變數!就令C變數是 Cn變數
For j = 1 To Cn
'↑設順迴圈!j從1 到Cn變數
Brr(i + 1, j + 5) = Application.Large(xD(T).keys, j)
'↑令歷史價左至右由大到小寫入Brr陣列裡
Next j
Next i
For j = 1 To C: Brr(1, j + 5) = "歷史價" & j: Next
'↑令設順迴圈處理 歷史價 的標題列
Brr(1, 5) = "現行價"
'↑標題列的現行價抬頭
'---------------------------------
Sheet2.UsedRange.ClearContents
'↑令結果表舊資料清除內容
Sheet2.[a1].Resize(R + 1, C + 5) = Brr
'↑令Brr陣列值寫入結果表[A1]開始的精確範圍
End Sub作者: 准提部林 時間: 2023-5-11 12:18
