[發問] 關於字典加陣列欄數問題

軒云熊

Dim X(1 To 4, 1 To 2) 的 1 TO  4 ,1 To 2
X(B, 2) = X(B, 2) + A(I, 2)  的 2
           X(K, 1) = A(I, 1) 的 1~2
           X(K, 2) = A(I, 2)
[D1].Resize(K, 2) 的 2
請問 如果要讓欄數改成動態該如何寫呢?


javascript:;

1. Sub 練習字典加陣列累加()
   
2. 
   
3.     Dim B, K
   
4.     Dim X(1 To 4, 1 To 2)
   
5.     Set D = CreateObject("Scripting.Dictionary")
   
6.     A = [A1:B1].Resize([B1].End(4).Row)
   
7. 
   
8.     For I = 1 To UBound(A)
   
9.    
   
10.         If D.Exists(A(I, 1)) Then
    
11.            B = D(A(I, 1))
    
12.            X(B, 2) = X(B, 2) + A(I, 2)
    
13.         Else
    
14.            K = K + 1
    
15.            D(A(I, 1)) = K
    
16.            X(K, 1) = A(I, 1)
    
17.            X(K, 2) = A(I, 2)
    
18.         End If
    
19. 
    
20.     Next I
    
21. 
    
22.     [D1].Resize(K, 2) = X
    
23. 
    
24. End Sub

複製代碼

軒云熊

Dim X(1 To 4, 1 To 2) 的 1 TO  4 ,1 To 2 列數 跟 欄數 還是說 直接給一個 較大的空間呢?

軒云熊

後來想到的辦法是這樣但 迴圈變多了.... XD 要縮減迴圈對我來說實在太困難了....還有一大段距離...

1. Sub 練習字典加陣列累加()
   
2. 
   
3.     Dim D As Object, B&, K&
   
4.    
   
5.     Set D = CreateObject("Scripting.Dictionary")
   
6.     A = Range(Cells(1, 1).End(4), Cells(1, 1).End(2))
   
7.     T = Cells(1, 1).End(4).Row
   
8.     L = Cells(1, 1).End(2).Column
   
9.     ReDim X(1 To T, 1 To L)
   
10. 
    
11.     For I = 1 To UBound(A)
    
12.         E = A(I, 1)
    
13.         If D.Exists(E) Then
    
14.            B = D(E)
    
15.             For F = 2 To UBound(X, 2)
    
16.                 If Not IsNumeric(A(I, F)) Then
    
17.                     X(B, F) = X(B, F)
    
18.                 Else
    
19.                     X(B, F) = X(B, F) + A(I, F)
    
20.                 End If
    
21.             Next F
    
22.         Else
    
23.            K = K + 1
    
24.            D(E) = K
    
25.             For Y = 1 To UBound(X, 2)
    
26.                 X(K, Y) = A(I, Y)
    
27.             Next Y
    
28.         End If
    
29.     Next I
    
30.    
    
31.     Cells(1, L + 2).Resize(K, Y - 1) = ""
    
32.     Cells(1, L + 2).Resize(K, Y - 1) = X
    
33. 
    
34. End Sub

複製代碼

javascript:;

Andy2483

回復 1# 軒云熊


    謝謝前輩發表此主題與範例
後學藉此帖練習一二維陣列與字典,學習的解決方案如下,請前輩參考

執行前:

下載 (74.69 KB)

2023-3-27 16:17

執行結果:

下載 (86.17 KB)

2023-3-27 16:17

Option Explicit
Sub TEST()
Dim Brr, Crr, i&, j&, xR, R&, T, A, Y, Z
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([F1], Cells(Rows.Count, "A").End(3))
Brr = xR: Z = Array(, 2, 3, 5)
ReDim Crr(1 To UBound(Brr, 2))
For i = 1 To UBound(Brr)
   A = Y(Brr(i, 1) & "")
   If Not IsArray(A) Then
      A = Crr
      For j = 1 To UBound(Crr): A(j) = Brr(i, j): Next
      Else
         For j = 1 To 3: A(Z(j)) = A(Z(j)) + Brr(i, Z(j)): Next
   End If
   Y(Brr(i, 1) & "") = A
Next
xR.Offset(, 14).EntireColumn.ClearContents
xR.Item(1, 15).Resize(Y.Count, UBound(Crr)) = _
Application.Transpose(Application.Transpose(Y.Items))
End Sub