|
|
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Dim rng As Range
gzb = ComboBox1.Text
If gzb = "" Then MsgBox "请选择要拆分的工作表名称！": Exit Sub
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
d(ListBox1.List(i, 0)) = ""
End If
Next i
If d.Count = 0 Then MsgBox "请选择要保留的工作表名称！": Exit Sub
Application.DisplayAlerts = False
For Each sh In Sheets
If Not d.exists(sh.Name) Then
sh.Delete
End If
Next sh
Application.DisplayAlerts = True
With Sheets(gzb)
rs = .Cells(Rows.Count, 13).End(xlUp).Row
ar = .Range("m1:m" & rs)
For i = 2 To UBound(ar)
If Trim(ar(i, 1)) <> "" Then
dc(Trim(ar(i, 1))) = ""
End If
Next i
For Each k In dc.keys
.Copy after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = k
For i = 2 To UBound(ar)
If Trim(.Cells(i, 13)) <> 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
End With
Set rng = Nothing
Next k
End With
Application.ScreenUpdating = True
MsgBox "拆分完毕！"
End
End Sub
Private Sub UserForm_Initialize()
Dim ar()
ReDim ar(1 To Sheets.Count)
For Each sh In Sheets
n = n + 1
ar(n) = sh.Name
Next sh
Me.ComboBox1.List = ar
Me.ListBox1.List = ar
End Sub
|
|
楼主: 赣州韵达
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2022-12-14 09:34
