½Ð±Ð¦U¦ì«e½úvba Ãö©ó³æ¤@Àx¦s®æ¦¡¤º²Î­p°ÝÃD~

ii31sakura

½Ð°Ý¦U¦ì¤j¤j¦]¤p§Ì©Ò¸I¨ì¸ê®Æ«¬ºA¦p¤U¡B«o¤]»Ý¶i¦æ²Î­p¡A½Ð°Ý¦¹ºØ¸ê®Æ§ÎºA¨Ï¥Îvba¦³¿ëªk²Î­p¶Ü¡H
¤£¦n·N«ä¦]¦¹ºØ³æ¤@Àx¦s®æ¶i¦æ²Î­p¡B¤p§Ì¤£ª¾¹D¦p¦óµÛ¤â¶i¦æ..©Ò¥H½Ð³Â·Ð¦U¦ì¤j¤j¤F¡C

ªþ¥ó»¡©ú¦p¤U¡G
1. A & B Ä欰¸ê®ÆDATA²M³æ
2.¥D­n°ÝÃD¬°BÄæ©Ò¨Ï¥Îªº¬OKEY in ¦b¤@°_ªº¸ê®Æ§ÎºA¡A¨Ò"B2" = 20-Ä«ªG («öENTER¦Ü¦P¤@®æ¤U¤èÄòKEY in)  50-­»¿¼  ¡A
    ¨Ã¥B¥X²{ªº¶µ¥Ø¤£¤@©w¡B¥uª¾¹D³æ¤@Àx¦s®æ¦¡¬° ¨Ò"B6"¡G ( ¼Æ¶q -¶µ¥Ø ) or ( ¼Æ¶q -¶µ¥Ø +enter ¼Æ¶q -¶µ¥Ø)

3.¦p¥i¶i¦æ²Î­p¡B½Ð°Ý­n«ç»ò¹³"F:H"Ä污ªp¦C¥X¦p¦¹ºØªº²Î­p²M³æ¥X¨Ó©O¡H(ªþ¥ó¤º®e"F:H"¬°¥Î¤âkey in¤W¥h..)


·PÁÂ~

stillfish00

¦^´_ 1# ii31sakura
¶È¨Ñ°Ñ¦Ò
³Ì¦nªº°µªkÁÙ¬O¤@¶}©lªºªí®æ´N¥ý©w¸q©ú½T¡A³æ¤@Àx¦s®æ¤£­n¦h¥Î³~¡C

1. Sub Test()
   
2.   Dim d, i As Long, dteDate As Date, lValue As Long, sType As String
   
3.   Dim oReg, oMatch, x, y, lCnt As Long, ar
   
4.   
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Set oReg = CreateObject("vbscript.regexp")
   
7.   With oReg
   
8.     .Global = True
   
9.     .Pattern = "(\d+)-(\S+)"
   
10.   End With
    
11.   
    
12.   'Analyze
    
13.   With Sheets("Sheet1").[A1].CurrentRegion
    
14.     If .Rows.Count < 2 Then Exit Sub
    
15.     For i = 2 To .Rows.Count
    
16.       dteDate = .Cells(i, 1).Value
    
17.       'make 2 levels dictionary
    
18.       If Not d.exists(dteDate) Then Set d(dteDate) = CreateObject("scripting.dictionary")
    
19.       
    
20.       Set oMatch = oReg.Execute(.Cells(i, 2).Value)
    
21.       For Each x In oMatch
    
22.         lValue = CLng(oReg.Replace(x.Value, "$1"))
    
23.         sType = oReg.Replace(x.Value, "$2")
    
24.         With d(dteDate)
    
25.           If .exists(sType) Then
    
26.             .Item(sType) = .Item(sType) + lValue
    
27.           Else
    
28.             .Item(sType) = lValue
    
29.             lCnt = lCnt + 1
    
30.           End If
    
31.         End With
    
32.       Next
    
33.     Next
    
34.   End With
    
35.   
    
36.   'Read to array
    
37.   ReDim ar(1 To lCnt, 1 To 3)
    
38.   i = 0
    
39.   For Each x In d.keys
    
40.     For Each y In d(x).keys
    
41.       i = i + 1
    
42.       ar(i, 1) = x
    
43.       ar(i, 2) = y
    
44.       ar(i, 3) = d(x)(y)
    
45.     Next
    
46.   Next
    
47.   'Fill into worksheet
    
48.   With Sheets("Sheet1").[F1]
    
49.     .Resize(1, 3).Value = Array("¤é´Á", "¨ä¥¦¶µ¥Ø", "¨ä¥¦Á`¼Æ¶q(Áû²É¼Æ)")
    
50.     .Offset(1).Resize(lCnt, 3).Value = ar
    
51.   End With
    
52. End Sub

½Æ»s¥N½X

ii31sakura

¦^´_ 2# stillfish00


    stillfish00¤j¤j»¡ªº¨S¿ù¡B³Ì¦nªº¤èªk¬O³æ¤@Àx¦s®æ³æ¥Î³~¡A
    ¥u¬O¦]¤p§Ì¸I¨ìªº¬O¹³¦¹ºØÃþ«¬ªºkey in¤è¦¡¥B®æ¦¡¥Ø«e¥u¯àÂê©w¦¹ºØkeyªk¦ý¤S»Ý¥h²Î­p¸Ì­±¦³¤°»ò¡B©Ò¥H«Ü·PÁÂstillfish00¤j¤jªºÀ°¦£®@~

Hsieh

¦^´_ 1# ii31sakura

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For Each a In Range([A2], [A2].End(xlDown)) '¨C¤é
   
4. ar = Split(a.Offset(, 1), Chr(10)) '´«¦æ¸ê®Æ
   
5. For Each k In ar
   
6.    s = Split(k, "-")(0): p = Split(k, "-")(1) '¨ú±o¼Æ¶q»P«~¦W
   
7.    If IsEmpty(d(a & p)) Then '¼g¤J¦r¨å
   
8.       d(a & p) = Array(a.Value, p, Val(s))
   
9.       Else
   
10.       d(a & p) = Array(a.Value, p, d(a & p)(2) + Val(s))
    
11.    End If
    
12. Next
    
13. Next
    
14. [F2].Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.items)) '¼g¤J¤u§@ªí
    
15. End Sub

½Æ»s¥N½X

c_c_lai

¦^´_ 4# Hsieh
«Ü¤£¿ùªº "Scripting.Dictionary" À³¥Î¡A
ÁÂÁ±z«ü¾É¡I

ii31sakura

¦^´_ 4# Hsieh


    «Ü·PÁÂHsieh¤j¤j´£¨Ñªº¥t¤@ºØ¤èªk¡BÅý¤p§Ì¥i¥H¾Ç¨ì§ó¦h¡A·PÁ¤j®aªºÀ°¦£®@~

Andy2483

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

°õ¦æ«e:

¤U¸ü (98.74 KB)

2023-4-18 09:51

°õ¦æµ²ªG:

¤U¸ü (114.3 KB)

2023-4-18 09:51

Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 100, 1 To 3), Y, Z, R&, R1&, i&, j&
Dim xR As Range, TT$, T1$, B$, A$
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([B1], Cells(Rows.Count, "A").End(3)): Brr = xR
For i = 2 To UBound(Brr)
   If i = 2 Then R = 1: Crr(R, 1) = "¤é´Á": Crr(R, 2) = "¶µ¥Ø": Crr(R, 3) = "Á`¼Æ"
   Z = Split(Brr(i, 2), vbLf): T1 = Brr(i, 1)
   For j = 0 To UBound(Z)
      A = Split(Z(j), "-")(0): B = Split(Z(j), "-")(1): TT = T1 & "|" & B
      If Y(TT) = "" Then
         R = R + 1: R1 = R: Y(TT) = R1
         Crr(R1, 1) = Brr(i, 1): Crr(R1, 2) = B
         Else
         R1 = Y(TT)
      End If
      Crr(R1, 3) = Crr(R1, 3) + Val(A)
   Next
Next
With [J1].Resize(R, 3)
   .EntireColumn.ClearContents
   .Value = Crr
   .Sort KEY1:=.Item(1), Order1:=1, _
         Key2:=.Item(2), Order2:=1, Header:=1
End With
Set Y = Nothing: Set xR = Nothing: Erase Brr, Crr, Z
End Sub