[µo°Ý] dictionary ¥Îªk

lalalada

¥H¤U¬°§Úªºµ{¦¡½X:

1. Dim Ar(), d As Object
   
2. Set d = CreateObject("scripting.dictionary")
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. Set dtemp = CreateObject("scripting.dictionary")
   
5. Ar = Range("A6:E" & [E6].End(xlDown).Row)
   
6. 
   
7. For i = 1 To UBound(Ar)
   
8.   If Not dtemp.exists(Left(Ar(i, 2), 4)) Then
   
9.   d.Add Ar(i, 2), Ar(i, 4)
   
10.   dic.Add Ar(i, 2), Ar(i, 5)
    
11.   dtemp.Add Left(Ar(i, 2), 4), Ar(i, 4)
    
12.   Else
    
13.   d(Ar(i, 2)) = d(Ar(i, 2)) + Ar(i, 4)
    
14.   dic(Ar(i, 2)) = dic(Ar(i, 2)) + Ar(i, 5)
    
15.   dtemp(Ar(i, 2)) = dtemp(Ar(i, 2)) + Ar(i, 4)
    
16.   End If
    
17. Next i

½Æ»s¥N½X

Ar ¦s©ñ¤@­Órange
¨ä§Î¦¡ªø³o¼Ë
§Ç        °Ó«~¦WºÙ              ¦¨¥æ³æ»ù        ÁʶR¼Æ¶q
1        131A ¹q¸£        150                 1,000
2        132A                 100                      0
3        55CR ¦B½c        800                      0
4        55CR               1200                  250
5        55CR               1150                  100

¦]¬°¦WºÙ¨Ã¥¼§¹¥þ¬Û¦P
·Q­n¥Îdictionary§¹¦¨¦U¶µ¥[Á`
¥i¬O¤£ª¾¹D¬°¦ódtemp¥i¥H¥[Á`
¦ý¬O d¸òdic´N¤£¦æ?
·PÁÂm(_ _)m

GBKEE

¦^´_ 1# lalalada
·Q­n¥Îdictionary§¹¦¨¦U¶µ¥[Á`,¥i¬O¤£ª¾¹D¬°¦ódtemp¥i¥H¥[Á`,¦ý¬O d¸òdic´N¤£¦æ?
¬Ý¬Ý¬O³o¼Ë¶Ü?

1. Option Explicit
   
2. Sub EX()
   
3. Dim Ar(), d As Object, dtemp As Object, dic As Object, i As Integer, xlword(1 To 3) As String
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     Set dtemp = CreateObject("scripting.dictionary")
   
7.     Ar = Range("A6:E" & [E6].End(xlDown).Row)
   
8.     For i = 1 To UBound(Ar)
   
9.         xlword(1) = Ar(i, 2)          '¥þ³¡¦r¦ê
   
10.         xlword(2) = Left(Ar(i, 2), 4) '¥N¸¹¦r¦ê
    
11.         xlword(3) = Mid(Ar(i, 2), 5)  '«~¦W¦r¦ê
    
12.    
    
13.         d(xlword(1)) = d(xlword(1)) + Ar(i, 4)
    
14.         If xlword(1) <> xlword(2) Then dic(xlword(2)) = dic(xlword(2)) + Ar(i, 5)
    
15.         If xlword(3) <> "" Then dtemp(xlword(3)) = dtemp(xlword(3)) + Ar(i, 4)
    
16.     Next
    
17. End Sub

½Æ»s¥N½X

lalalada

¦^´_  lalalada
·Q­n¥Îdictionary§¹¦¨¦U¶µ¥[Á`,¥i¬O¤£ª¾¹D¬°¦ódtemp¥i¥H¥[Á`,¦ý¬O d¸òdic´N¤£¦æ?
¬Ý¬Ý¬O ...
GBKEE µoªí©ó 2012-8-13 12:13

¦n¹³©Ç©Çªº...
³Ì«á¤@¬q
        d(xlword(1)) = d(xlword(1)) + Ar(i, 4)
        If xlword(1) <> xlword(2) Then dic(xlword(2)) = dic(xlword(2)) + Ar(i, 5)
        If xlword(3) <> "" Then dtemp(xlword(3)) = dtemp(xlword(3)) + Ar(i, 4)
·N«ä¤À§O¬O:
¥þ¦W = ¥N½X + «~¦W
¦r¨å1«Ø¥ßÃöÁä¦r(°O¿ý©Ò¦³ÃöÁä¦r¡A³¡¤À¬°¥þ¦W¡A³¡¤À¥u¦³¥N½X)
­Y¥Ø«eªº¥þ¦W¤£¥u¦³¥ªÃä¥N½X «h¦r¨å2(¬ö¿ý¦P®É¦³¥N½X+«~¦W¶µ)¥[¤JÃöÁä¦r¤Î¯Á¤Þ
­Y«~¦W¤£¬°ªÅ¥Õ«h¦r¨å3(¬ö¿ý¦P®É¦³¥N½X+«~¦W¶µ)¥[¤JÃöÁä¦r¯Á¤Þ
³o¼Ë¬Ý°_¨Ó³Ì«áµLªk§â©Ò¦³¬Û¦P¥N½Xªº²£«~¥[Á`¿é¥X?@@
ex. SSSL ¹q¸£   $100    50
      SSSL             $150    25
      SSSL             $50      100
¿é¥X¦¨
SSSL   ¹q¸£   175
³Ì«á¥Ø¼Ð¬O
SSSL   ¹q¸£   $¥­§¡»ù®æ  175

lalalada

©êºp¤@¶}©l±Ô­z¤£²M
§Ú§â­ì¨Óªºcode¥[¤Wµù¸Ñ

1. Dim Ar()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. Set dtemp = CreateObject("scripting.dictionary")
   
5. Ar = Range("A6:E" & [E6].End(xlDown).Row)
   
6. 
   
7. For i = 1 To UBound(Ar)
   
8.   If dtemp.exists(Left(Ar(i, 2), 4)) = False Then  '­Y¦r¨å3¥N½X¥¼¬ö¿ý
   
9.   d(Ar(i, 2)) = Ar(i, 4)                            '¦r¨å1¬ö¿ý¥þ¦W¤Î¯Á¤Þ1
   
10.   dic(Ar(i, 2)) = Ar(i, 5)                         '¦r¨å2¬ö¿ý¥þ¦W¤Î¯Á¤Þ2
    
11.   dtemp(Left(Ar(i, 2), 4)) = Ar(i, 4)              '¦r¨å3¬ö¿ý¥N½X¤Î¯Á¤Þ
    
12.     MsgBox "d:" & d(Ar(i, 2)) & d.keys & "  dic:" & dic(Ar(i, 2)) & " dtemp:" & dtemp(Left(Ar(i, 2), 4))
    
13.   Else                                                             '­Y¦r¨å3¥N½X¤w°O¿ý
    
14.   dtemp(Left(Ar(i, 2), 4)) = dtemp(Left(Ar(i, 2), 4)) + Ar(i, 4) '¦r¨å3¯Á¤Þ1¥[Á`
    
15.   d(Ar(i, 2)) = d(Ar(i, 2)) + Ar(i, 4)                          '¦r¨å1(¥þ¦W)¯Á¤Þ1¥[Á`
    
16.   dic(Ar(i, 2)) = dic(Ar(i, 2)) + Ar(i, 5)                    '¦r¨å2(¥þ¦W)¯Á¤Þ2¥[Á`
    
17.     MsgBox "ELSE    ""d:" & d(Ar(i, 2)) & "  dic:" & dic(Ar(i, 2)) & " dtemp:" & dtemp(Left(Ar(i, 2), 4))
    
18.   End If
    
19. Next i
    
20. 
    
21. [L6].Resize(d.Count, 1) = Application.Transpose(d.keys)          '¿é¥X¥þ¦W
    
22. [M6].Resize(d.Count, 1) = Application.Transpose(d.items)      '¿é¥X¯Á¤Þ1
    
23. [N6].Resize(dic.Count, 1) = Application.Transpose(dic.items) '¿é¥X¯Á¤Þ2

½Æ»s¥N½X

´«¥y¸Ü»¡
§Æ±æ³Ì«á¯à¿é¥X¦r¨å1ªº¥þ¦W©M¦r¨å3ªº¯Á¤Þ­È...."
¥Ø«e°ÝÃD¥d¦b·í±ø¥ó¬°§_
dtemp¥i½T¹ê¥[Á`¦ýd,dic¤£¦æ(¥Ñmsgbox¥i¥HÆ[¹î¨ì)
·PÁª©¤j¦^´_:)
¥»¨Ó¥H¬°¤w¸g¨I¨ì¶³²`¤£ª¾³B

GBKEE

¦^´_ 4# lalalada

¤W¶ÇÀÉ®× ¬Ý¬Ý

lalalada

¦^´_  lalalada
½Ð¶Ç¤WexcelÀÉ®×
GBKEE µoªí©ó 2012-8-13 16:09

ªü ©êºp
§¹¥þ§Ñ°O¥i¥H¤W¶Ç...
§Ú¯u²Â..."
­è­è­«¼g¤F¥ÎDo...Loopªº°µªk
¤]ªþ¦bÀɮ׸Ì
dictionaryªº¤èªk code¸Ìªº°Ñ·Ó¦ì¸m­nµy·L½Õ¾ã¤@¤U¤~¯à¥Î

lalalada

¦^´_ 6# lalalada

Àɮ׸̪ºcode¶K¦¨¨Sµù¸Ñª©ªº¤F..."

GBKEE

¦^´_ 7# lalalada
©JÀÉ ¦p¦³¸Ô²Ó»¡©ú ´N¤£·|Ãú¸Ì¬Ýªá¤F

ex. SSSL ¹q¸£   $100    50
      SSSL             $150    25
      SSSL             $50      100
¿é¥X¦¨
SSSL   ¹q¸£   175
³Ì«á¥Ø¼Ð¬O
SSSL   ¹q¸£   $¥­§¡»ù®æ  175

µ{¦¡½X¨ÌªþÀÉÄæ¦ì, ¤u§@ªí1 ªº¸ê®Æ¤w±Æ§Ç¹L  ©w»s

1. Sub arrange_trial()
   
2.     Dim Ar(), Axy(), d As Object, dic As Object, xlword As String
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     Ar = Sheets("¤u§@ªí1").Range("A2:E" & Sheets("¤u§@ªí1").[E2].End(xlDown).Row).Value
   
6.     '***  ¤@¯ë¼Ò²Õ¤¤: ¨S«ü©w¤u§@ªíªº Range ¬O·|§@¥Î¤¤¤u§@ªíActiveSheetªºRange   ****
   
7.     For i = 1 To UBound(Ar)
   
8.         If Len(Ar(i, 2)) > 4 Then xlword = Ar(i, 2)
   
9.         If Not d.Exists(xlword) Then
   
10.             d(xlword) = Array(Ar(i, 1), Ar(i, 2), , Ar(i, 4), Ar(i, 5))
    
11.             dic(xlword) = Array(Ar(i, 3))          'p
    
12.         Else
    
13.             Axy = d(xlword)   '¨ú±o ¦r¨åª«¥óªºitems
    
14.             d(xlword) = Array(Axy(0), Axy(1), , Axy(3) + Ar(i, 4), Axy(4) + Ar(i, 5))
    
15.             
    
16.             Axy = dic(xlword) '¨ú±o ¦r¨åª«¥óªºitems
    
17.             ReDim Preserve Axy(UBound(dic(xlword)) + 1)  '­«¸m Axy¤¸¯À+1(Preserve: ­û¤º®e¤£ÅÜ)
    
18.             Axy(UBound(Axy)) = Ar(i, 3)                  '¥[1 ªº¤¸¯À
    
19.             dic(xlword) = Axy '¸m¤J ¦r¨åª«¥óªºitems
    
20.         End If
    
21.     Next
    
22.     For Each k In d.keys
    
23.         Axy = d(k)
    
24.         Axy(2) = Application.Average(dic(k))  '¥­§¡¼Æ
    
25.         Axy(2) = Application.Round(Axy(2), 2) '¥|±Ë¤­¤J¨ì¤p¼ÆÂI²Ä2¦ì
    
26.         d(k) = Axy
    
27.     Next
    
28.     Sheets("Output").[a5].Resize(d.Count, UBound(Ar, 2)) = Application.Transpose(Application.Transpose(d.items))
    
29. End Sub

½Æ»s¥N½X

lalalada

¦^´_ 8# GBKEE

§Ú·|¤F!:P
­ì¨Ó°}¦C³o»ò¦n¥Î...
¥»¨Ó¤£¼ô¥H¬°¤Ï¥¿¥i¥H¥ÎÀx¦s®æ¨ú¥N §Ú­n¦A¦h¬ã¨s..
¦Ó¥Bdictionary³ºµM¥i¥Hª½±µ«ü©w°}¦C
³o¦¸¯uªºÀò¯q¨}¦h
·PÁª©¤j!:)

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

¸ê®Æªí:

¤U¸ü (91.5 KB)

2023-4-14 14:19

µ²ªGªí °õ¦æ«e:

¤U¸ü (34.35 KB)

2023-4-14 14:20

°õ¦æµ²ªG:

¤U¸ü (52.7 KB)

2023-4-14 14:20

Option Explicit
Sub TEST()
Dim Brr, Y, R&, i&, j&, T$, T0$
Dim xR As Range, Sh1 As Worksheet, Sh2 As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("¤u§@ªí1"): Set Sh2 = Sheets("Output")
Set xR = Sh1.[A1].CurrentRegion: Brr = xR
For i = 2 To UBound(Brr)
   T = Trim(Brr(i, 2))
   If T = "" Then GoTo i01
   If T Like "C### [A-Z]*" Then
      R = R + 1
      T0 = Split(T, " ")(0)
      Y(T0 & "|r") = R: Y(T0 & "|n") = 1: Y(T0 & "|tt") = Brr(i, 3)
      For j = 1 To 5: Brr(R, j) = Brr(i, j): Next
      GoTo i01
   End If
   Y(T & "|n") = Y(T & "|n") + 1
   Y(T & "|tt") = Y(T & "|tt") + Brr(i, 3)
   Brr(Y(T & "|r"), 3) = Round(Y(T & "|tt") / Y(T & "|n"), 2)
   Brr(Y(T & "|r"), 4) = Brr(Y(T & "|r"), 4) + Brr(i, 4)
   Brr(Y(T & "|r"), 5) = Brr(Y(T & "|r"), 5) + Brr(i, 5)
   
i01:
Next
[5:65536].Clear
Sh2.[A5].Resize(R, 5) = Brr
Set Y = Nothing: Set xR = Nothing: Erase Brr
Set Sh1 = Nothing: Set Sh2 = Nothing
End Sub