mdr0465

回復 10# 准提部林

准提部林, 謝謝你提供這麼多的範例, 實在太有用了, 後學定必細心學習,謝謝

Andy2483

回復 10# 准提部林


    謝謝論壇,謝謝前輩指導
後學藉此帖練習陣列與字典,學習方案如下,請前輩再指導

一維轉二維_Xl0000016範例
執行前:

下載 (119.06 KB)

2023-5-5 10:12

執行結果:

下載 (158.91 KB)

2023-5-5 10:12

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

回復 10# 准提部林


    謝謝論壇,謝謝前輩指導
後學藉此帖練習陣列與字典,學習方案如下,請前輩再指導

一維轉二維_Xl0000016範例,在字典中做合計的學習方案

Option Explicit
Sub TEST_1()
Dim Brr, Y, R&, C%, Nr&, Nc%, i&, j%, 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
   Y(T1 & "|r") = Y(T1 & "|r") + Brr(i, 3): Y(T2 & "|c") = Y(T2 & "|c") + Brr(i, 3)
   Nr = Y(T1): Nc = Y(T2): Crr(Nr, Nc) = Crr(Nr, Nc) + Brr(i, 3): Y("|Tt") = Y("|Tt") + Brr(i, 3)
   If i = UBound(Brr) Then
      For j = 2 To R: Crr(Y(Crr(j, 1)), C + 1) = Y(Crr(j, 1) & "|r"): Next
      For j = 2 To C: Crr(R + 1, Y(Crr(1, j))) = Y(Crr(1, j) & "|c"): Next
      Crr(R + 1, C + 1) = Y("|Tt")
   End If
i01: Next
Sh.[F1].CurrentRegion.EntireColumn.Clear
With Sh.[F1].Resize(R + 1, C + 1)
   .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
   Union(.Item(R + 1, 1), .Item(1, C + 1)) = "TOTAL"
   .EntireColumn.AutoFit: .Borders.LineStyle = 1
   Union(.Rows(1), .Rows(R + 1), .Columns(1), .Columns(C + 1)).Font.Bold = True
End With
Set Y = Nothing: Set Sh = Nothing: Erase Brr, Crr
End Sub

gaishutsusuru

回復 6# 准提部林

謝謝前輩幫忙。

另外，想請教前輩，我試著將您的檔案的Sheet1的A1~F9的資料複製起來，另外再建一個新檔來測試巨集。
結果會跳錯誤訊息：執行階段錯誤'424'，此處需要物件。
而偵錯時是「Arr = Sheet1.[a1].CurrentRegion」這行出現問題。

請問是哪個步驟操作錯誤呢? 該如何處理呢? 謝謝前輩

Andy2483

回復 14# gaishutsusuru
回復 6# 准提部林


    謝謝前輩發表此主題與範例
謝謝 准提部林前輩指導
後學藉此帖學習前輩的方案,方案學習心得註解如下,請前輩再指導

資料表:

下載 (39.28 KB)

2023-5-11 09:15

結果表:

下載 (22.5 KB)

2023-5-11 09:15

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

准提部林

回復 14# gaishutsusuru

改這樣試試~~
Arr = Sheets("工作表名稱").[a1].CurrentRegion

gaishutsusuru

回復 16# 准提部林

謝謝前輩幫忙

gaishutsusuru

回復 15# Andy2483

也謝謝前輩針對程式碼做如此仔細的分析。