[µo°Ý] Ãö©ó¦r¨å¥[°}¦CÄæ¼Æ°ÝÃD

°a¤ªºµ

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
½Ð°Ý ¦pªG­nÅýÄæ¼Æ§ï¦¨°ÊºA¸Ó¦p¦ó¼g©O?


javascript:;

1. Sub ½m²ß¦r¨å¥[°}¦C²Ö¥[()
   
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

½Æ»s¥N½X

Andy2483

¦^´_ 1# °a¤ªºµ


    ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
«á¾ÇÂǦ¹©«½m²ß¤@¤Gºû°}¦C»P¦r¨å,¾Ç²ßªº¸Ñ¨M¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò

°õ¦æ«e:

¤U¸ü (74.69 KB)

2023-3-27 16:17

°õ¦æµ²ªG:

¤U¸ü (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

°a¤ªºµ

«á¨Ó·Q¨ìªº¿ìªk¬O³o¼Ë¦ý °j°éÅܦh¤F.... XD ­nÁY´î°j°é¹ï§Ú¨Ó»¡¹ê¦b¤Ó§xÃø¤F....ÁÙ¦³¤@¤j¬q¶ZÂ÷...

1. Sub ½m²ß¦r¨å¥[°}¦C²Ö¥[()
   
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

½Æ»s¥N½X

javascript:;

°a¤ªºµ

Dim X(1 To 4, 1 To 2) ªº 1 TO  4 ,1 To 2 ¦C¼Æ ¸ò Äæ¼Æ ÁÙ¬O»¡ ª½±µµ¹¤@­Ó ¸û¤jªºªÅ¶¡©O?