没有合适的资源?快使用搜索试试~ 我知道了~
资源推荐
资源详情
资源评论
Sub aaa()
Dim arr, rng As Range, d As Object, k, t, i&, lc%, sh As Worksheet, ICol%, shp As Shape
ICol = Application.InputBox("请输入你所要分的列:(如按B列分请输入2)", "提示:", "2", Type:=1)
If ICol = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Name <> "总表" Then sh.Delete'“总表”为工作表名称,若为其他名称,则相应修改。
Next
arr = Range("a1").CurrentRegion
lc = UBound(arr, 2)
Set rng = Rows(1)
Set d = CreateObject("scripting.dictionary")
For i = 4 To UBound(arr) '若标题为3行,则i=4
If Not d.Exists(arr(i, ICol)) Then
Set d(arr(i, ICol)) = Cells(i, 1).Resize(1, lc)
Else
Set d(arr(i, ICol)) = Union(d(arr(i, ICol)), Cells(i, 1).Resize(1, lc))
End If
Next
k = d.keys
t = d.Items
For i = 0 To d.Count - 1
Sheets("总表").Copy After:=Sheets(Sheets.Count)'“总表”为工作表名称,若为其他名称,则相应修改。
With ActiveSheet
For Each shp In .Shapes
shp.Delete
Next
.Name = k(i)
.UsedRange.Offset(3).Clear '若有三行标题,则Offset(3)
Dim arr, rng As Range, d As Object, k, t, i&, lc%, sh As Worksheet, ICol%, shp As Shape
ICol = Application.InputBox("请输入你所要分的列:(如按B列分请输入2)", "提示:", "2", Type:=1)
If ICol = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Name <> "总表" Then sh.Delete'“总表”为工作表名称,若为其他名称,则相应修改。
Next
arr = Range("a1").CurrentRegion
lc = UBound(arr, 2)
Set rng = Rows(1)
Set d = CreateObject("scripting.dictionary")
For i = 4 To UBound(arr) '若标题为3行,则i=4
If Not d.Exists(arr(i, ICol)) Then
Set d(arr(i, ICol)) = Cells(i, 1).Resize(1, lc)
Else
Set d(arr(i, ICol)) = Union(d(arr(i, ICol)), Cells(i, 1).Resize(1, lc))
End If
Next
k = d.keys
t = d.Items
For i = 0 To d.Count - 1
Sheets("总表").Copy After:=Sheets(Sheets.Count)'“总表”为工作表名称,若为其他名称,则相应修改。
With ActiveSheet
For Each shp In .Shapes
shp.Delete
Next
.Name = k(i)
.UsedRange.Offset(3).Clear '若有三行标题,则Offset(3)
资源评论
lyx00000xx
- 粉丝: 4
- 资源: 16
上传资源 快速赚钱
- 我的内容管理 展开
- 我的资源 快来上传第一个资源
- 我的收益 登录查看自己的收益
- 我的积分 登录查看自己的积分
- 我的C币 登录后查看C币余额
- 我的收藏
- 我的下载
- 下载帮助
安全验证
文档复制为VIP权益,开通VIP直接复制
信息提交成功