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

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

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

½Ð°Ý¦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ÁÂ~

³æ¤@Àx¦s®æ¤º®etest²Î­p.rar (14.77 KB)

¥»©«³Ì«á¥Ñ stillfish00 ©ó 2014-5-26 19:59 ½s¿è

¦^´_ 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

TOP

¦^´_ 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ªºÀ°¦£®@~

TOP

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

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

TOP

¦^´_ 4# Hsieh


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

TOP

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

°õ¦æ«e:


°õ¦æµ²ªG:



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

TOP

        ÀR«ä¦Û¦b : §g¤l¦p¤ô¡AÀH¤è´N¶ê¡AµL³B¤£¦Û¦b¡C
ªð¦^¦Cªí ¤W¤@¥DÃD