Sub 拆分()
Dim sh As Worksheet, sh1 As Worksheet, i&, j&, k&, r1&, r&, rstar&, rlast&
Dim arr, brr, danw, d As Object, crr, cr, rg As Range
Application.ScreenUpdating = False '关闭屏幕刷新，以提高运行速度。
Set sh1 = Sheets("总表") '为sh1赋值，以方便后面使用简单，后面的sh1就是“总表”
Set d = CreateObject("scripting.dictionary") '创建一个字典对象
arr = sh1.Range("a1:n1") '把第一行的数据装入数组，以便为分表添加标题行。
r1 = sh1.Range("m" & Rows.Count).End(3).Row '求得总表的最下端的行号。
brr = sh1.Range("m2:m" & r1) '把单位这一列的数据装入桶数组brr
For i = 1 To UBound(brr) '循环brr中的值，得到去除重复后的单位名称及它们所在的行号。等号前是名称，等号后是这个单位的行号。
d(brr(i, 1)) = d(brr(i, 1)) & "\" & i + 1
Next i
danw = d.keys '把字典中的keys（单位名称）装入数组danw中
crr = d.items '把字典中的items(单位所对应的行号）装入数组crr中。
For j = 0 To UBound(danw) '循环单位名称
For Each sh In Sheets '循环工作表
If sh.Name = danw(j) Then '如果这个单位名称的工作表名已经存在就计一个数：
k = 1 'k=1
Exit For '退出循环
End If
Next sh
If k = 0 Then '如果k=0，说明这个单位的工作表名称不存在，那么
Sheets.Add after:=Sheets(Sheets.Count) '在最后的工作表新建一个工作表
ActiveSheet.Name = danw(j) '新建的工作表名称为：这个不存在的单位名
End If
k = 0 '把k的值还原为0,以便下一次使用。
Next j
For j = 0 To d.Count - 1 '循环单位名所对应的工作表
cr = Split(Right(crr(j), Len(crr(j)) - 1), "\") '刚才把各单位名称所在的行号以"\"号连接，所以要以"\"切分开。得到一个行数的数组。
For i = 0 To UBound(cr) '循环行数这个数组
If rg Is Nothing Then '判断rg对象是否为空。如果为空，那么：
Set rg = sh1.Cells(cr(i), 1) '为rg赋值为第一个行号所在的第一列这个单元格
Else '否则，如果rg不为空，那么
Set rg = Union(rg, sh1.Cells(cr(i), 1)) '为rg赋值：用原来rg的单元格合并上新的行所在的第一列的单元格。
End If
Next i
rg.EntireRow.Copy '把所有连接起来的这个单位所在的行进行复制。
With Sheets(danw(j)) '以这个单位名称的工作表为对象，下面的点（.)就是对它进行操作。
.Cells = "" '清空这个单位名称的工作表
.Range("a1:n1") = arr '这个单位的工作表的第一行写入标题行arr的值。
.Range("a2").PasteSpecial Paste:=xlPasteColumnWidths '以a2为顶点进行选择性粘贴，粘贴总表的列宽为原来的总表的列宽相同
.Paste '再粘贴数据 '
End With
Set rg = Nothing '清空rg对象，方便下复制一个单位名称时选择区域使用。
Next j
sh1.Activate '激活总表。
Application.CutCopyMode = False '退出复制和剪切模式
Application.ScreenUpdating = True '开启屏幕刷新。
End Sub
IP卡
狗仔卡
发表于 2014-1-6 19:48
提升卡
置顶卡
沉默卡
喧嚣卡
变色卡
抢沙发
千斤顶
显身卡
楼主
非常完美，太感谢了！能给解释一下代码吗？我怕以后有要调整的时候不知道怎么弄，比如说增加了几列内容，或者增加了几行数据的时候。
