|
|
Sub 拆分为工作表()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long
Dim arr()
Dim d As Object
Dim sh As Worksheet
Dim rng As Range
Set sh = ThisWorkbook.Worksheets("数据汇总表")
Set d = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
For Each sht In Sheets
If sht.Name <> sh.Name Then
sht.Delete
End If
Next sht
Application.DisplayAlerts = True
With sh
r = .Cells(Rows.Count, 2).End(xlUp).Row
ar = .Range("a1:l" & r)
End With
For i = 4 To UBound(ar)
If Trim(ar(i, 2)) <> "" Then
d(Trim(ar(i, 2))) = ""
End If
Next i
For Each k In d.keys
sh.Copy after:=Sheets(Sheets.Count)
With Sheets(Sheets.Count)
.Name = k
For i = 4 To UBound(ar)
If Trim(.Cells(i, 2)) <> k Then
If rng Is Nothing Then
Set rng = .Rows(i)
Else
Set rng = Union(rng, .Rows(i))
End If
End If
Next i
For Each sp In .Shapes
sp.Delete
Next sp
End With
If Not rng Is Nothing Then rng.Delete
Set rng = Nothing
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-3-13 09:10
楼主
