|
Sub mf()
Application.ScreenUpdating = False
Dim sht As Worksheet
Dim i As Integer
Dim ar As Variant
Dim rng As Range
Dim d As Object
Set d = CreateObject("scripting.dictionary")
t = Timer
Application.DisplayAlerts = False
For Each sht In Sheets
If sht.Name <> "总表" And sht.Name <> "辅助表" Then
sht.Delete
End If
Next
Application.DisplayAlerts = True
ar = Sheets("总表").[a1].CurrentRegion
For i = 2 To UBound(ar)
If Trim(ar(i, 7)) <> "" Then
d(Trim(ar(i, 7))) = ""
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, 7)) <> k Then
If rng Is Nothing Then
Set rng = .Rows(i)
Else
Set rng = Union(rng, .Rows(i))
End If
End If
Next i
If Not rng Is Nothing Then rng.Delete
For Each sp In .Shapes
sp.Delete
Next sp
End With
Set rng = Nothing
Next k
Set d = Nothing
Set rng = Nothing
Application.ScreenUpdating = True
MsgBox "表格拆分完毕,耗时:" & Format(Timer - t, "0.00") & "秒", 64, "提醒"
End Sub
|
评分
-
1
查看全部评分
-
|