|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Dim rn As Range
Dim sht As Worksheet, sh As Worksheet
Set d = CreateObject("scripting.dictionary")
lh = Application.InputBox("请输入拆分条件所在列:", "指定拆分条件所在列", "E", Type:=2)
bt = Application.InputBox("指定标题行数，该区域不参与拆分", "标题行数", "1", Type:=1)
If lh = False Then Exit Sub
If bt = False Then Exit Sub
Application.DisplayAlerts = False
For Each sht In ThisWorkbook.Sheets
If sht.Name <> "卡片管理" Then sht.Delete
Next sht
Application.DisplayAlerts = True
Set sh = Sheets("卡片管理")
With sh
r = .Cells(Rows.Count, lh).End(xlUp).Row
ar = .Range(.Cells(1, lh), .Cells(r, lh))
End With
For i = bt + 1 To UBound(ar)
If Trim(ar(i, 1)) <> "" Then
d(Trim(ar(i, 1))) = ""
End If
Next i
For Each k In d.keys
sh.Copy after:=Sheets(Sheets.Count)
With ActiveSheet
For i = bt + 1 To UBound(ar)
If Trim(.Cells(i, lh)) <> k Then
If rn Is Nothing Then
Set rn = .Rows(i)
Else
Set rn = Union(rn, .Rows(i))
End If
End If
Next i
.Name = k
End With
If Not rn Is Nothing Then rn.Delete
Set rn = Nothing
Next k
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub |
|
楼主: XXZSP2
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-5-26 08:40
楼主