|
|
本帖最后由 3190496160 于 2020-5-2 12:21 编辑
本工具最大特点，可以完全保留原工作表的所有格式设置，包括页面设置，
可以自由选择拆分依据列，标题行数，拆分为工作表还是拆分为工作簿文件，
Sub chaifen()
Set d = CreateObject("scripting.dictionary")
Dim rg As Range
On Error Resume Next
Set rg = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)
If rg Is Nothing Then MsgBox "您没有选择拆分依据列": Exit Sub
Application.ScreenUpdating = False '关闭屏幕更新
r = rg.Column
p = InputBox("请输入标题行数", "标题行", "1")
If p = "" Then MsgBox "您没有输入标题行数": Exit Sub
pp = MsgBox("拆分为工作表选【是】，拆分为工作簿选【否】", vbYesNo)
Set sh = ThisWorkbook.ActiveSheet
ar = sh.[a1].CurrentRegion
For i = Val(p) + 1 To UBound(ar)
If Trim(ar(i, r)) <> "" Then
d(Trim(ar(i, r))) = ""
End If
Next i
If pp = vbNo Then GoTo 10
Application.DisplayAlerts = False '关闭警告信息提示
For Each sht In Worksheets '遍历一遍工作表，如果字典中存在则删除
If d.exists(sht.Name) Then sht.Delete
Next sht
Application.DisplayAlerts = True
10:
Dim rng As Range
For Each k In d.keys
If pp = vbYes Then
sh.Copy after:=Sheets(Sheets.Count)
With Sheets(Sheets.Count)
For i = Val(p) + 1 To UBound(ar)
If Trim(.Cells(i, r)) <> 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
For Each ss In .Shapes
ss.Delete
Next ss
.Name = k
End With
Set rng = Nothing
ElseIf pp = vbNo Then
sh.Copy
With ActiveWorkbook.Worksheets(1)
For i = Val(p) + 1 To UBound(ar)
If Trim(.Cells(i, r)) <> 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
For Each ss In .Shapes
ss.Delete
Next ss
.Name = k
End With
Set rng = Nothing
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & k
ActiveWorkbook.Close
End If
Next k
Set d = Nothing
Application.ScreenUpdating = True '恢复屏幕更新
MsgBox "数据拆分完成！"
End Sub
|
评分
-
18
查看全部评分
-
|
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2020-4-25 15:04
楼主
发表于 2020-4-25 20:21
