Hsieh

¦^´_ 5# sandra_wang
©pªº½d¨Òªºmiddle¦n¹³À³¸Ó¥u¦³¤@µ§¤~¹ï

1. Sub Ex()
   
2. Dim A As Range, d As Object, Col As Integer, s As Long, r As Long, k As Integer, Mystr As String
   
3. Dim ky As Variant
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set A = Range([M1], [M1].End(xlToRight))
   
6. A.Resize(10, A.Count) = ""
   
7. Col = 13
   
8. For k = 8 To 10
   
9. If Application.Count(Columns(k)) > 0 Then
   
10.    For Each A In Columns(k).SpecialCells(xlCellTypeConstants, 1)
    
11.       For i = 1 To A
    
12.          s = s + 1
    
13.          r = A.Row
    
14.          Mystr = Replace(Cells(1, k), "¼Æ¶q", "_") & s
    
15.          d(Mystr) = Application.Transpose(Cells(r, 2).Resize(, 4))
    
16.       Next
    
17.    Next
    
18.    
    
19.    For Each ky In d.keys
    
20.       Cells(1, Col) = ky
    
21.       Cells(3, Col).Resize(4, 1) = d(ky)
    
22.       Col = Col + 1
    
23. 
    
24.    Next
    
25. End If
    
26. s = 0: d.RemoveAll
    
27. Next
    
28. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 8# sandra_wang

1. Sub Ex()
   
2. Dim A As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set Rng = Range("CL2,CX2,DJ2")
   
5. [ED2:EL65536] = ""
   
6. r = 2
   
7. For Each A In Rng
   
8.    k = 135
   
9.    For i = 7 To 9
   
10.    s = 1
    
11.       If Application.Count(A.Offset(, i).EntireColumn) > 0 Then
    
12.       Cells(r, 134).Resize(5, 1) = Application.Transpose(Array(A, A.Offset(1, 1), A.Offset(1, 2), A.Offset(1, 3), A.Offset(1, 4)))
    
13.          For Each b In A.Offset(, i).EntireColumn.SpecialCells(xlCellTypeConstants, 1)
    
14.             For j = 1 To b
    
15.                Mystr = Cells(3, b.Column) & "_" & s
    
16.                s = s + 1
    
17.                d(Mystr) = Application.Transpose(Cells(b.Row, A.Column + 1).Resize(, 4))
    
18.             Next
    
19.          Next
    
20.          For Each ky In d.keys
    
21.             Cells(r, k) = ky: Cells(r + 1, k).Resize(4, 1) = d(ky)
    
22.             k = k + 1
    
23.          Next
    
24.          d.RemoveAll
    
25.       End If
    
26.       Next
    
27.       r = r + 12
    
28. Next
    
29. End Sub

½Æ»s¥N½X