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