[µo°Ý] ¤ñ¹ï¦hµ§¸ê®Æ

lalalada

DATA.zip (971.83 KB)

¤U¸ü¦¸¼Æ: 24

2012-8-17 16:47

¦pªþÀÉ
¦³¦hµ§°Ó«~³ø»ù¸ê®Æ
¦ý¬O¨CºØ°Ó«~ªº¸ê®Æ¤é´Á¤£§¹¥þ¤@¼Ë
²{¦b·Q¶]²Î­p¦^Âk ©Ò¥H·Q¨ú¥X³ø»ù¤é´Áªº¥æ¶°
§Y¥u¦³·í¬Y¤é´Á¦³°Ó«~¬Ò¦³³ø»ù¸ê®Æ®É¤~±Ä¥Î §_«h±Ë±ó
¤@¶}©l·Q¨ì¨Ï¥Îcountif §ì¥X¬Ò¦³ªº¸ê®Æ
¦ý®Ä²v¤£¬Æ¦n µM«á·Q¨ì¥Î°}¦C
¤£ª¾¹D¦p¦ó¤ñ¹ï¤£¦P°}¦C¶¡ªº¸ê®Æ©O?
ex. °}¦Ca()¤¤¥ô¤@µ§¸ê®Æ(¤é´Á)­Y¦s¦b©ó¨ä¥L©Ò¦³°}¦C«h«O¯d
³Ì¤j°ÝÃDÂI¦b©ó¬Y¤@¤é´ÁÁö¦s¦b©ó©Ò¦³°}¦C
¦ý¬O¦ì¸m¤£©T©w
©Ò¥HµLªk¥H²³æ°j°é¶]§¹
­Y¬O³sÄò¨Ï¥ÎÂù°j°éªº¸Ü¦n¹³·|«ÜºC(¦]¬°¦³¦h­Ó°}¦C)
©Ò¥H·Qª¾¹D¦³¨S¦³§Ö³t¤ñ¸û¸ê®Æ¦s¦bªº¤èªk
©Î¬O¦³¨ä¥L¥i¥H¤ñ¹ï¤j¶q¸ê®Æªº¤è¦¡?
·PÁÂ~

white945

¦^´_ 1# lalalada

1. Sub §ì¨ú¤é´Á¥æ¶°()
   
2. Dim Ay(), Ty()
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set d1 = CreateObject("Scripting.Dictionary")
   
5. ar = Range("A1").CurrentRegion.Value
   
6. ReDim Preserve Ty(0)
   
7. Ty(0) = "Date"
   
8. For j = 1 To UBound(ar, 2) Step 2
   
9. k = k + 1
   
10. ReDim Preserve Ty(k)
    
11. Ty(k) = ar(3, j + 1)
    
12.   For i = 5 To UBound(ar, 1)
    
13.   If IsDate(ar(i, j)) Then
    
14.     d(ar(i, j)) = d(ar(i, j)) + 1
    
15.     If IsEmpty(d1(ar(i, j))) Then
    
16.       ReDim Preserve Ay(0)
    
17.       Ay(0) = ar(i, j + 1)
    
18.       d1(ar(i, j)) = Ay
    
19.     Else
    
20.       Ay = d1(ar(i, j))
    
21.       ReDim Preserve Ay(UBound(Ay) + 1)
    
22.       Ay(UBound(Ay)) = ar(i, j + 1)
    
23.       d1(ar(i, j)) = Ay
    
24.     End If
    
25.     Erase Ay
    
26.   End If
    
27.   Next
    
28. Next
    
29. For Each ky In d.keys
    
30.   If d(ky) <> k Then d1.Remove ky
    
31. Next
    
32. Cells(3, k * 2 + 3).Resize(, k + 1) = Ty
    
33. Cells(4, k * 2 + 3).Resize(d1.Count, 1) = Application.Transpose(d1.keys)
    
34. Cells(4, k * 2 + 4).Resize(d1.Count, k) = Application.Transpose(Application.Transpose(d1.items))
    
35. End Sub

½Æ»s¥N½X

lalalada

¦^´_ 2# white945

¦n­C!
¦r¨å·f°t°}¦CªGµM¬O¾ã²z¸ê®Æªº¦n¤u¨ã
§Ú¦A¬ã¨s¤@¤U
·PÁ§A:)

Andy2483

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

°õ¦æ«e:

¤U¸ü (300.68 KB)

2023-4-14 11:54

°õ¦æµ²ªG:

¤U¸ü (373.69 KB)

2023-4-14 11:55

Option Explicit
Sub TEST()
Dim Brr, Crr, V, Y, R&, i&, j&, N&, T$, Tv
Dim xR As Range, Sh As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = Sheets("5Y-Data")
Set xR = Intersect(Sh.[A1].CurrentRegion, Sh.UsedRange.Offset(2, 0))
Brr = xR
For i = 1 To UBound(Brr)
   For j = 1 To UBound(Brr, 2) Step 2
      T = Brr(i, j): Tv = Brr(i, j + 1)
      If i = 1 Then T = "Date"
      If T = "" Then GoTo i01
      Y(T) = Y(T) + 1: Y(T & "|c") = j \ 2 + 1
      Y(T & "|" & Y(T & "|c")) = Tv
      If Y(T) = 6 Then R = R + 1
   Next
i01:
Next
ReDim Crr(1 To R, 1 To 7)
For Each V In Y.keys
   If Y(V) = 6 And InStr(V, "|") = 0 Then
      N = N + 1: Crr(N, 1) = V
      For j = 1 To 6
         Crr(N, j + 1) = Y(V & "|" & j)
      Next
   End If
Next
With Sh.[O3].Resize(R, 7)
   .EntireColumn.ClearContents
   .Value = Crr
End With
Set Y = Nothing: Set xR = Nothing: Set Sh = Nothing: Erase Brr, Crr
End Sub