EXCEL 拆分工作表（根据不同内容简历新的工作簿）

yangjkab · 发表于 2013-9-17 16:01

本帖最后由 yangjkab 于 2013-9-17 16:08 编辑

谁能给个思路~最好给个代码~一个EXCEL工作表里存着一下数据：
要实现，把编码相同的数据，存放到一个新的工作簿中。如例子中有编码000001，001201，001202，001203，001204
则自动新建4个名字为000001，001201，001202，001203，001204的工作簿，并把相应的数据填写进去。
由于编码比较多，所以用一行一行扫描的方法效率比较低下。谁有好的方法和代码么

编码	数据A	数据B	数据C	数据D
000001	35	16	54	42
000001	40	23	34	84
001201	2	55	40	22
001201	7	89	2	89
001201	78	93	41	23
001201	9	59	29	39
000001	21	8	99	10
001211	91	43	48	65
001211	86	15	42	84
001201	3	58	43	62
001202	20	50	77	27
001203	17	10	34	21
001204	25	31	35	92

zhaogang1960 · 发表于 2013-9-17 16:10

请测试:

Sub Macro1()
Dim arr, brr, d As Object, k, t, i&, j&, m&, l&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
arr = [a1].CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) & "," & i
Next
k = d.Keys
brr = arr
For i = 0 To d.Count - 1
m = 1
t = Split(d(k(i)), ",")
For j = 1 To UBound(t)
m = m + 1
For l = 1 To UBound(arr, 2)
brr(m, l) = arr(t(j), l)
Next
Next
With Workbooks.Add(xlWBATWorksheet)
.Sheets(1).[a1].Resize(m, UBound(arr, 2)) = brr
.SaveAs ThisWorkbook.Path & "" & k(i) & ".xlsx"
.Close
End With
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

复制代码

zhaogang1960 · 发表于 2013-9-17 16:11

请看附件

数据测试.rar (41.87 KB, 下载次数: 140)

yangjkab · 发表于 2013-9-17 16:22

zhaogang1960 发表于 2013-9-17 16:11
请看附件

大侠。你太厉害了。测试正确。能否写一些备注，给代码解释一下。。我是个初学者，有点看不懂这个高深的代码~因为我的原始数据，不能透露，所以我还要根据你的代码进行一定的修改。

zhaogang1960 · 发表于 2013-9-17 16:33

yangjkab 发表于 2013-9-17 16:22
大侠。你太厉害了。测试正确。能否写一些备注，给代码解释一下。。我是个初学者，有点看不懂这个高深的代 ...

原理很简单,主要是字典应用:

Sub Macro1()
Dim arr, brr, d As Object, k, t, i&, j&, m&, l&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary") '创建字典对象
arr = [a1].CurrentRegion '数据区域写入数组
For i = 2 To UBound(arr) '逐行
d(arr(i, 1)) = d(arr(i, 1)) & "," & i '编码和行号关联
Next
k = d.Keys '字典键值数组
brr = arr '数组brr赋值，同时把arr中的标题行传递到brr
For i = 0 To d.Count - 1 '逐个编码
m = 1 '保留标题行
t = Split(d(k(i)), ",") '每个编号所对应的行号
For j = 1 To UBound(t) '逐个行号
m = m + 1 '计数
For l = 1 To UBound(arr, 2) '逐行
brr(m, l) = arr(t(j), l) '该编码对应的行数据写入brr
Next
Next
With Workbooks.Add(xlWBATWorksheet) '新建一个工作簿
.Sheets(1).[a1].Resize(m, UBound(arr, 2)) = brr '写数据
.SaveAs ThisWorkbook.Path & "" & k(i) & ".xlsx" '保存文件
.Close '关闭
End With
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "OK"
End Sub

复制代码

yangjkab · 发表于 2013-9-17 16:35

zhaogang1960 发表于 2013-9-17 16:33
原理很简单,主要是字典应用:

谢谢啦。我去搜一下字典应用。第一次接触这个东西。

yangjkab · 发表于 2013-9-26 16:45

zhaogang1960 发表于 2013-9-17 16:33
原理很简单,主要是字典应用:

大侠，在问一下，我用你的这个宏。只能把数据的值复制过去。但是如果我的原始单元格有背景色，和字体颜色，就都复制不过去了。有什么改善方法嘛

yangjkab · 发表于 2013-9-26 17:00

yangjkab 发表于 2013-9-26 16:45
大侠，在问一下，我用你的这个宏。只能把数据的值复制过去。但是如果我的原始单元格有背景色，和字体颜色 ...

每行格式都可能不一样。所以不能最后处理完，刷元表的格式。

LMY123 · 发表于 2017-10-4 17:01

字典拆分工作薄

		自动登录	找回密码
密码			免费注册

EXCEL 拆分工作表（根据不同内容简历新的工作簿）

评分