Hsieh

回復 1# opman
直接在BOOK1的工作表模組執行
將會產生新工作表於BOOK1

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. Dim Ar()
   
4. With 工作表1
   
5.    For Each a In .Range(.[A2], .[A2].End(xlDown))
   
6.       sh = Int(a / 100) & "年" & a Mod 100 & "班" & a.Offset(, 5) '班級科目字串
   
7.       If IsEmpty(d(sh)) Then
   
8.          ReDim Ar(1)
   
9.          Ar(0) = .[A1:O1].Value '標題列
   
10.          Ar(1) = Application.Transpose(Application.Transpose(a.Resize(, 15).Value)) '第一個資料列
    
11.          d(sh) = Ar
    
12.          Else
    
13.          Ar = d(sh) '讀出陣列
    
14.          s = UBound(Ar) + 1
    
15.          ReDim Preserve Ar(s)
    
16.          Ar(s) = Application.Transpose(Application.Transpose(a.Resize(, 15).Value)) '加入資料列
    
17.          d(sh) = Ar '寫回陣列
    
18.        End If
    
19.    Next
    
20. End With
    
21. For Each ky In d.keys
    
22. With Worksheets.Add(after:=Sheets(Sheets.Count)) '插入工作表
    
23.    .Name = ky '工作表命名
    
24.    .Cells.NumberFormat = "@" '設成文字格式
    
25.    .[A1].Resize(UBound(d(ky)) + 1, 15) = Application.Transpose(Application.Transpose(d(ky))) '寫入資料
    
26. End With
    
27. Next
    
28. End Sub

複製代碼