|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub 分表()
Application.ScreenUpdating = False
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim ar As Variant
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Index > 2 Then sh.Delete
Next sh
Application.DisplayAlerts = True
ar = Sheets("序时簿").[a1].CurrentRegion
For i = 2 To UBound(ar)
If Trim(ar(i, 10)) <> "" Then
d(Trim(ar(i, 10))) = ""
End If
Next i
For Each k In d.keys
n = 0
ReDim br(1 To UBound(ar), 1 To 10)
For i = 2 To UBound(ar)
If Trim(ar(i, 10)) = k Then
n = n + 1
For j = 1 To UBound(ar, 2) - 1
br(n, j) = ar(i, j)
Next j
br(n, 10) = ar(i, 9)
End If
Next i
Sheets("模板").Copy after:=Sheets(Sheets.Count)
With Sheets(Sheets.Count)
.Name = k
.[b4] = k
.[a8].Resize(n, UBound(br, 2)) = br
.Rows(n + 8 & ":135").Delete
End With
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|