- 帖子
- 1018
- 主題
- 15
- 精華
- 0
- 積分
- 1058
- 點名
- 0
- 作業系統
- win7 32bit
- 軟體版本
- Office 2016 64-bit
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 桃園
- 註冊時間
- 2012-5-9
- 最後登錄
- 2022-9-28
|
2#
發表於 2013-12-20 21:50
| 只看該作者
本帖最後由 stillfish00 於 2013-12-20 22:01 編輯
回復 1# Genie - Sub test()
- Dim ar, d, arEQ, i As Long
-
- '複製來源
- With Sheets("Sheet1")
- .AutoFilterMode = False
- .[A1].CurrentRegion.Copy Sheets("Sheet2").[A1]
- .[A1].AutoFilter
- End With
-
- With Sheets("Sheet2")
- '排序
- With .Sort
- .SortFields.Clear
- .SortFields.Add .Parent.Range("B2:B" & Rows.Count), xlSortOnValues, xlAscending
- .SortFields.Add .Parent.Range("C2:C" & Rows.Count), xlSortOnValues, xlAscending
- .SetRange .Parent.[A1].CurrentRegion
- .Header = xlYes
- .Orientation = xlTopToBottom
- .SortMethod = xlPinYin
- .Apply
- End With
-
- '找出每段起始位置
- ar = .[A1].CurrentRegion.Value
- Set d = CreateObject("scripting.dictionary")
- For i = 2 To UBound(ar)
- If ar(i, 2) <> ar(i - 1, 2) Then d(ar(i, 2)) = i
- Next i
-
- '由後往前分割,插入空白
- arEQ = d.keys
- For i = UBound(arEQ) To LBound(arEQ) + 1 Step -1
- .Range(.Cells(d(arEQ(i)), "D"), .Cells(.Rows.Count, "D")).Insert xlToRight
- .Rows(d(arEQ(i))).Insert xlDown
- Next i
- .[D1].Resize(, d.Count).Value = d.keys
- End With
- End Sub
複製代碼 |
|