Hsieh

回復 4# rouber590324
試試看

1. Sub ex()
   
2. Dim A As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. With Sheets(1)
   
5. For Each A In .Range(.[A1], .[A1].End(xlDown))
   
6.   If d(Left(A, 7)) = "" Then
   
7.      d(Left(A, 7)) = Join(Application.Transpose(Application.Transpose(A.Resize(, 5))), ";")
   
8.      Else
   
9.      d(Left(A, 7)) = d(Left(A, 7)) & Chr(10) & Join(Application.Transpose(Application.Transpose(A.Resize(, 5))), ";")
   
10.   End If
    
11. Next
    
12. For Each ky In d.keys
    
13.   ar = Split(d(ky), Chr(10))
    
14.   For Each c In ar
    
15.      If Split(c, ";")(4) = "" Then d.Remove ky
    
16.   Next
    
17. Next
    
18. On Error Resume Next
    
19. For Each ky In d.keys
    
20.   ar = Split(d(ky), Chr(10))
    
21.   For Each c In ar
    
22.   ay = Split(c, ";")
    
23.   ay(3) = CDate(ay(3))
    
24.   ay(4) = CDate(ay(4))
    
25.     Sheets(2).Cells(r + 1, 1).Resize(, 5) = ay
    
26.     r = r + 1
    
27.   Next
    
28. Next
    
29. End With
    
30. End Sub

複製代碼