b9208

回復 6# Hsieh
Dear Hsieh
非常感謝幫忙與指導
目前運行上是ok的
謝謝

b9208

回復 7# ML089
Dear ML089

謝謝參與指導與討論，可以學習使用函數組合運用。
超版的vba可以統計筆數及數量。

b9208

回復 6# Hsieh
Dear Hsieh

For Each a In Range([B8], [B8].End(xlDown))
m = a.Text & "," & a.Offset(, 2) & "," & a.Offset(, 4)
n = a.Text & "," & a.Offset(, 1) & "," & a.Offset(, 2)
   If d(m) <= a.Offset(, 7) Then d(m) = a.Offset(, 7)
   d1(n) = ""
Next
  
上句中 d1(n) = ""   之用意為何？
感謝指導

b9208

回復 6# Hsieh
Dear Hsieh
程式及輸出資料在同一工作表，執行OK。
如果程式及輸出表格置於sheet2，基本資料置於sheet1，輸出資料都是0。修訂如下：
With Sheets("sheet1")
For Each a In Range([B8], [B8].End(xlDown))
..........
.........................
End With
For Each a In [N8:N14]

另請教增加直接計算加總 Total 功能，如何修改。謝謝

Hsieh

回復 14# b9208

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. Set d1 = CreateObject("Scripting.Dictionary")
   
4. With Sheets("Sheet1")
   
5. For Each a In .Range(.[B8], .[B8].End(xlDown))
   
6. m = a.Text & "," & a.Offset(, 2) & "," & a.Offset(, 4)
   
7. n = a.Text & "," & a.Offset(, 1) & "," & a.Offset(, 2)
   
8.    If d(m) <= a.Offset(, 7) Then _
   
9.    d(m) = a.Offset(, 7) '取出B、D、F欄同組最大值
   
10.    d1(n) = "" 'B、C、D欄不重複索引
    
11. Next
    
12. End With
    
13. For Each ky In d.keys
    
14.   ar = Split(ky, ",")
    
15.   d(ar(0) & ar(1)) = d(ar(0) & ar(1)) + d(ky) '取出B、D、F欄同組加總
    
16. Next
    
17. For Each ky In d1.keys
    
18.   ar = Split(ky, ",")
    
19.   d1(ar(0) & ar(2)) = d1(ar(0) & ar(2)) + 1 ''B、C、D欄組合計數
    
20. Next
    
21. With Sheets("Sheet2")
    
22. For Each c In .[O7:P7]
    
23. cnt = 0
    
24.    For Each a In .[N8:N14]
    
25.     .Cells(a.Row, c.Column) = IIf(d1(a & c) = "", 0, d1(a & c))  '依序填入組合計數
    
26.      cnt = cnt + d1(a & c)
    
27.    Next
    
28. .Cells(15, c.Column) = cnt
    
29. Next
    
30. For Each c In .[O7:P7]
    
31. cnt = 0
    
32.     For Each a In .[N19:N25]
    
33.      .Cells(a.Row, c.Column) = IIf(d(a & c) = "", 0, d(a & c)) '依序填入組合加總
    
34.      cnt = cnt + d1(a & c)
    
35.    Next
    
36. .Cells(26, c.Column) = cnt
    
37. Next
    
38. End With
    
39. End Sub

複製代碼

T1.rar (13.39 KB)

下載次數: 17

2013-4-27 23:20

b9208

回復 15# Hsieh
謝謝版主
可以執行
符合需求

freeffly

回復 15# Hsieh


    一行一行看能大略能解讀
   不過要自己寫出來有點難
   學習了

b9208

回復 15# Hsieh
Dear Hsieh

For Each a In .Range(.[B8], .[B8].End(xlDown))
m = a.Text & "," & a.Offset(, 2) & "," & a.Offset(, 4)
n = a.Text & "," & a.Offset(, 1) & "," & a.Offset(, 2)
   If d(m) <= a.Offset(, 7) Then _
   d(m) = a.Offset(, 7) '取出B、D、F欄同組最大值
   d1(n) = "" 'B、C、D欄不重複索引
Next
上述程式中   d1(n) = "" 'B、C、D欄不重複索引
思考很久了還是無法理解
d1(n) 設定成""，後續如何計數？
懇請指導

Hsieh

回復 18# b9208
在此階段的字典作用，主要是取得項目
先知道同組的索引有哪些?
後面
For Each ky In d1.keys
  ar = Split(ky, ",")
  d1(ar(0) & ar(2)) = d1(ar(0) & ar(2)) + 1 ''B、C、D欄組合計數
Next
這段就是讓B、D欄相同者計數

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教
執行前:

下載 (163.45 KB)

2024-1-24 08:53

執行結果:

下載 (178.05 KB)

2024-1-24 08:54

Option Explicit
Sub TEST()
Dim Arr, Brr, Crr(8, 100), A%, Z, B%, V%, i&, C%, T2$, T3$, T4$, T6$, T9$
ActiveSheet.UsedRange.EntireColumn.Offset(, 17).Delete
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([I7], [A65536].End(3))
Crr(0, 0) = Brr(1, 2) & " \ " & Brr(1, 4)
For i = 2 To 8: Crr(i - 1, 0) = Format(i, "DDD"): Z(Crr(i - 1, 0)) = i - 1: Next
Crr(8, 0) = "TOTAL": Arr = Crr
For i = 2 To UBound(Brr)
   T2 = Format(Brr(i, 1), "DDD"): T4 = Brr(i, 4): T6 = Brr(i, 6): T3 = Brr(i, 3): T9 = Brr(i, 9)
   A = Z(T2): B = Z(T4): V = Z(T2 & T6 & T4)
   If B = 0 Then C = C + 1: B = C: Z(Brr(i, 4)) = B: Arr(0, C) = Brr(i, 4): Crr(0, C) = Brr(i, 4)
   If Z(T2 & T3 & T4) = 0 Then Z(T2 & T3 & T4) = 1: Crr(A, B) = Crr(A, B) + 1
   If V = 0 Then V = Val(T9): Z(T2 & T6 & T4) = V: Arr(A, B) = Arr(A, B) + V: GoTo i01
   If Z(T2 & T6 & T4) < Val(T9) Then
      Arr(A, B) = Arr(A, B) - Z(T2 & T6 & T4) + Val(T9): Z(T2 & T6 & T4) = Val(T9)
   End If
i01: Next
[R6] = "統計組別筆數"
With [R7].Resize(9, C + 1)
   .Value = Crr: .SpecialCells(4) = 0: .Borders.LineStyle = 1: .EntireColumn.HorizontalAlignment = xlCenter
   .Offset(, 1).Sort KEY1:=.Item(1), Order1:=1, Header:=1, Orientation:=2
   .Item(9, 2).Resize(, C) = "=SUM(" & Intersect(.Columns(2), [8:14]).Address(0, 0) & ")"
End With
[R17] = "計算數量"
With [R18].Resize(9, C + 1)
   .Value = Arr: .SpecialCells(4) = 0: .Borders.LineStyle = 1: .Columns(1).EntireColumn.AutoFit
   .Offset(, 1).Sort KEY1:=.Item(1), Order1:=1, Header:=1, Orientation:=2
   .Item(9, 2).Resize(, C) = "=SUM(" & Intersect(.Columns(2), [19:25]).Address(0, 0) & ")"
End With
End Sub