自动拆分表格问题

wujing0701 · 发表于 2012-6-7 22:27

111.rar (29.01 KB, 下载次数: 339)

如附件所示，想把根据第一列的字段拆分出若干个不同的表格，最好能够直接新建EXCEL表，或者在一个表里分成若干个子表，名称按首列字段定义，非常感谢！

wenwu0318 · 发表于 2012-6-7 22:41

用彭大的工具啊！

zhaogang1960 · 发表于 2012-6-7 23:07

本帖最后由 zhaogang1960 于 2012-6-7 23:09 编辑

请测试

Sub Macro1()
Dim cnn As Object, rs As Object, SQL$, sFile$, i&
Set cnn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.Recordset")
cnn.Open "Provider=Microsoft.ace.Oledb.12.0;Extended Properties=Excel 12.0 Xml;Data Source=" & ThisWorkbook.FullName
SQL = "select distinct 部门 from [" & ActiveSheet.Name & "$] where 部门 is not null"
rs.Open SQL, cnn, 1, 3
For i = 1 To rs.RecordCount
sFile = ThisWorkbook.Path & "" & rs.Fields(0).Value & ".xlsx"
If Dir(sFile) <> "" Then Kill sFile
SQL = "select * into [" & sFile & "].[Sheet1] from [" & ActiveSheet.Name & "$] where 部门='" & rs.Fields(0).Value & "'"
cnn.Execute SQL
rs.MoveNext
Next
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
MsgBox "拆分完成！", vbInformation
End Sub

复制代码

zhaogang1960 · 发表于 2012-6-7 23:11

请注意，标题不能有重复，也不要有空格
请看附件

拆分.rar (38.38 KB, 下载次数: 1033)

wujing0701 · 发表于 2012-6-8 10:02

我下载了，不行啊，点完怎么没有动静了？

zhaogang1960 · 发表于 2012-6-8 10:30

wujing0701 发表于 2012-6-8 10:02
我下载了，不行啊，点完怎么没有动静了？

下载到哪里了？请看演示：

wujing0701 · 发表于 2012-6-8 14:23

成功了，非常感谢，这个功能太好，省了我好多的工作量！

LMY123 · 发表于 2012-7-7 23:54

谢谢版主的再次指导，经试用，效果好极了。

zhaogang1960 · 发表于 2012-7-7 23:44

LMY123 发表于 2012-7-7 23:34
请问我改为按第三列拆分，代码为什么不对
Sub Macro1()
Dim cnn As Object, rs As Object, SQL$, sFi ...

代码没有问题，工作簿名违规了：
<、- 等

LMY123 · 发表于 2012-7-7 23:45

谢谢版主的指导

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

[已解决] 自动拆分表格问题