color790

感謝版主的幫忙, 自己要好好用功消化一下....

Andy2483

回復 1# color790


    謝謝論壇,謝謝前輩發表此主題與範例,謝謝各位前輩
後學藉此帖練習陣列與字典,學習的方案如下,請各位前輩指教

執行前:

下載 (171.73 KB)

2023-3-31 08:56

執行結果:

下載 (210.92 KB)

2023-3-31 08:56

Option Explicit
Sub TEST()
Dim Brr, Y, N&, i&, j&, T&, T2&, T3&
Dim xR As Range, Ra As Range, Sh As Sheets
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([C1], Cells(Rows.Count, "A").End(xlUp))
Brr = xR: N = 1
For i = 2 To UBound(Brr)
   T = Brr(i, 1): T2 = Brr(i, 2): T3 = Brr(i, 3)
   If Y(T) = "" Then
      N = N + 1: Y(T) = N: Brr(N, 1) = T: Brr(N, 3) = T3
      Y(T & "|sd") = T2: Brr(N, 2) = T2 - Y(T & "|sd")
      Else
         Brr(Y(T), 2) = T2 - Y(T & "|sd")
         Brr(Y(T), 3) = Brr(Y(T), 3) + T3
   End If
Next
With xR.Offset(, 15)
   .EntireColumn.ClearContents: .Resize(N, 3) = Brr
End With
Set Y = Nothing: Set xR = Nothing: Erase Brr
End Sub

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,添加最低價/最高價/均價,請各位前輩指教

執行結果:

下載 (254.42 KB)

2023-3-31 09:59

Option Explicit
Sub TEST_1()
Dim Brr, Y, N&, S&, i&, j&, T&, T2&, T3&
Dim xR As Range, Ra As Range, Sh As Sheets
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([F1], Cells(Rows.Count, "A").End(xlUp))
Brr = xR: N = 1
For i = 2 To UBound(Brr)
   T = Brr(i, 1): T2 = Brr(i, 2): T3 = Brr(i, 3)
   If Y(T) = "" Then
      N = N + 1: Y(T) = N: S = N: Brr(N, 1) = T: Brr(N, 3) = T3
      Y(T & "|sd") = T2: Y(T & "|mi") = T2: Y(T & "|ma") = T2
      Else
         N = Y(T): Brr(N, 3) = Brr(N, 3) + T3
         Y(T & "|mi") = IIf(T2 > Y(T & "|mi"), Y(T & "|mi"), T2)
         Y(T & "|ma") = IIf(T2 < Y(T & "|ma"), Y(T & "|ma"), T2)
   End If
   Y(T & "|q") = Y(T & "|q") + T3: Y(T & "|tot") = Y(T & "|tot") + (T2 * T3)
   Brr(N, 2) = T2 - Y(T & "|sd")
   Brr(N, 4) = Y(T & "|mi"): Brr(N, 5) = Y(T & "|ma")
   Brr(N, 6) = Y(T & "|tot") / Y(T & "|q")
Next
With xR.Offset(, 15)
   .EntireColumn.ClearContents: .Resize(S, 6) = Brr
   .Item(1, 4).Resize(1, 3) = [{"最低價","最高價","均價"}]
End With
Set Y = Nothing: Set xR = Nothing: Erase Brr
End Sub