|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub test()
Dim d As Object, k, lr&, r&, c%, i%, m%, ar, t As Range
Sheet1.Activate
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
Set t = [a2:c2]
UsedRange.Offset(1, 5).Clear
lr = Cells(Rows.Count, 2).End(xlUp).Row
ar = [b1].Resize(lr + 1)
For r = 2 To lr
If ar(r + 1, 1) <> ar(r, 1) Then d(r + 1) = ""
Next
k = d.keys
Set d = Nothing
c = 7
For i = 0 To UBound(k) - 1
m = Application.WorksheetFunction.Ceiling((i + 1) / 2, 1)
Cells(2, c + 1) = "第" & m & "组" & Space(1) & ar(k(i), 1)
t.Copy Cells(3, c)
Cells(k(i), 1).Resize(k(i + 1) - k(i), 3).Copy Cells(4, c)
c = c + 5
Next
Set t = Nothing
Application.ScreenUpdating = True
End Sub |
|