ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

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

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

¥»©«³Ì«á¥Ñ °a¤ªºµ ©ó 2020-8-16 12:17 ½s¿è

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.     Dim B, K
  3.     Dim X(1 To 4, 1 To 2)
  4.     Set D = CreateObject("Scripting.Dictionary")
  5.     A = [A1:B1].Resize([B1].End(4).Row)

  6.     For I = 1 To UBound(A)
  7.    
  8.         If D.Exists(A(I, 1)) Then
  9.            B = D(A(I, 1))
  10.            X(B, 2) = X(B, 2) + A(I, 2)
  11.         Else
  12.            K = K + 1
  13.            D(A(I, 1)) = K
  14.            X(K, 1) = A(I, 1)
  15.            X(K, 2) = A(I, 2)
  16.         End If

  17.     Next I

  18.     [D1].Resize(K, 2) = X

  19. End Sub
½Æ»s¥N½X

½m²ß.rar (11.33 KB)

¥»©«³Ì«á¥Ñ °a¤ªºµ ©ó 2020-8-16 12:26 ½s¿è

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

TOP

¥»©«³Ì«á¥Ñ °a¤ªºµ ©ó 2020-8-16 18:06 ½s¿è

«á¨Ó·Q¨ìªº¿ìªk¬O³o¼Ë¦ý °j°éÅܦh¤F.... XD ­nÁY´î°j°é¹ï§Ú¨Ó»¡¹ê¦b¤Ó§xÃø¤F....ÁÙ¦³¤@¤j¬q¶ZÂ÷...
  1. Sub ½m²ß¦r¨å¥[°}¦C²Ö¥[()

  2.     Dim D As Object, B&, K&
  3.    
  4.     Set D = CreateObject("Scripting.Dictionary")
  5.     A = Range(Cells(1, 1).End(4), Cells(1, 1).End(2))
  6.     T = Cells(1, 1).End(4).Row
  7.     L = Cells(1, 1).End(2).Column
  8.     ReDim X(1 To T, 1 To L)

  9.     For I = 1 To UBound(A)
  10.         E = A(I, 1)
  11.         If D.Exists(E) Then
  12.            B = D(E)
  13.             For F = 2 To UBound(X, 2)
  14.                 If Not IsNumeric(A(I, F)) Then
  15.                     X(B, F) = X(B, F)
  16.                 Else
  17.                     X(B, F) = X(B, F) + A(I, F)
  18.                 End If
  19.             Next F
  20.         Else
  21.            K = K + 1
  22.            D(E) = K
  23.             For Y = 1 To UBound(X, 2)
  24.                 X(K, Y) = A(I, Y)
  25.             Next Y
  26.         End If
  27.     Next I
  28.    
  29.     Cells(1, L + 2).Resize(K, Y - 1) = ""
  30.     Cells(1, L + 2).Resize(K, Y - 1) = X

  31. End Sub
½Æ»s¥N½X
javascript:;

½m²ß.rar (12.91 KB)

TOP

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


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

°õ¦æ«e:
20230327_1.jpg
2023-3-27 16:17


°õ¦æµ²ªG:
20230327_2.jpg
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
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

        ÀR«ä¦Û¦b : ¤@­Ó¯Ê¤fªºªM¤l¡A¦pªG´«¤@­Ó¨¤«×¬Ý¥¦¡A¥¦¤´µM¬O¶êªº¡C
ªð¦^¦Cªí ¤W¤@¥DÃD