|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub 拆分()
Application.ScreenUpdating = False
Dim d As Object
Dim ar As Variant
Dim rng As Range
Set d = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Index > 1 Then sh.Delete
Next sh
Application.DisplayAlerts = True
ar = Sheets("总表").[a1].CurrentRegion
For i = 2 To UBound(ar)
If Trim(ar(i, 5)) <> "" Then
d(Trim(ar(i, 5))) = ""
End If
Next i
For Each k In d.keys
Sheets("总表").Copy after:=Sheets(Sheets.Count)
With Sheets(Sheets.Count)
.Name = k
For i = 2 To UBound(ar)
If Trim(.Cells(i, 5)) <> k Then
If rng Is Nothing Then
Set rng = .Rows(i)
Else
Set rng = Union(rng, .Rows(i))
End If
End If
Next i
rng.Delete
Set rng = Nothing
End With
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
评分
-
1
查看全部评分
-
|