如何快速将一个excel表拆分成多个独立的excel

sandy408

如题，需要将一个汇总的工资表按照门店拆分成多个工资表后（最好能自动按门店名称命名），下发给各个门店。请各位大虾帮忙，折腾了我好久了~~~

无限趋向

MARK  关注

李兴德

透视表吧      

mineshine

1. Sub test()
   
2. Dim dic As Object, i As Long, a
   
3.     Dim AWB As Workbook, BWB As Workbook
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False    '关闭提醒
   
6.     On Error Resume Next
   
7.     Set AWB = ThisWorkbook
   
8.     Set dic = CreateObject("scripting.dictionary")  '字典
   
9.     For i = 2 To Sheet1.Cells(Sheet1.Rows.Count, 4).End(xlUp).Row
   
10.         If Not dic.exists(Sheet1.Cells(i, 4) & "") Then dic.Add Sheet1.Cells(i, 4), "" '取不重复部门
    
11.     Next i
    
12.     a = dic.keys
    
13.     Set conn = CreateObject("adodb.connection")
    
14.     conn.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;hdr=yes';data source=" & ThisWorkbook.FullName
    
15.     For i = 0 To dic.Count - 1
    
16.         Sql = "select * from [" & Sheet1.Name & "$] where 岗位='" & a(i) & "'"
    
17.         Set BWB = Workbooks.Add '新增工作簿
    
18.         ActiveWorkbook.SaveAs Filename:=AWB.Path & "" & a(i) & ".xlsx" '保存新增工作簿，文件名a(i)
    
19.         With BWB.Sheets(1)
    
20.             .UsedRange.Clear
    
21.             AWB.Sheets(1).Rows(1).Copy .Cells(1, 1) '表头
    
22.             .Cells(2, 1).CopyFromRecordset conn.Execute(Sql) '查询结果写入A2
    
23.             BWB.Save    '保存
    
24.             BWB.Close    '关闭
    
25.         End With
    
26.     Next i
    
27.     conn.Close
    
28.     Set conn = Nothing
    
29.     Set dic = Nothing
    
30.     Application.DisplayAlerts = True    '开启提醒
    
31.     Application.ScreenUpdating = True
    
32. End Sub

复制代码

李兴德

工资表.zip (754.5 KB, 下载次数: 354)

2012-12-5 15:02 上传

点击文件名下载附件

sandy408

mineshine 发表于 2012-12-5 14:54

亲，是按“门店”，不是按“部门”，完全看不懂，这方面是白痴啊，帮忙再改一下好不？谢谢鸟~~~

sandy408

李兴德 发表于 2012-12-5 15:02

大虾，您这个数据透视表怎么快速取消行标签里自动生成的那个“汇总”项，我原来也是这么做的，但每项都会有一个“汇总”，我每次都要手动删除。麻烦的。而且用透视不能生成独立的excel表，还要一份一份移出来。

mineshine

sandy408 发表于 2012-12-5 15:09
亲，是按“门店”，不是按“部门”，完全看不懂，这方面是白痴啊，帮忙再改一下好不？谢谢鸟~~~

1. 
   
2. Sub test()
   
3. Dim dic As Object, i As Long, a
   
4.     Dim AWB As Workbook, BWB As Workbook
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False    '关闭提醒
   
7.     On Error Resume Next
   
8.     Set AWB = ThisWorkbook
   
9.     Set dic = CreateObject("scripting.dictionary")  '字典
   
10.     For i = 2 To Sheet1.Cells(Sheet1.Rows.Count, 2).End(xlUp).Row
    
11.         If Not dic.exists(Sheet1.Cells(i, 2) & "") Then dic.Add Sheet1.Cells(i, 2), "" '取不重复门店
    
12.     Next i
    
13.     a = dic.keys
    
14.     Set conn = CreateObject("adodb.connection")
    
15.     conn.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;hdr=yes';data source=" & ThisWorkbook.FullName
    
16.     For i = 0 To dic.Count - 1
    
17.         Sql = "select * from [" & Sheet1.Name & "$] where 门店='" & a(i) & "'"
    
18.         Set BWB = Workbooks.Add '新增工作簿
    
19.         ActiveWorkbook.SaveAs Filename:=AWB.Path & "" & a(i) & ".xlsx" '保存新增工作簿，文件名a(i)
    
20.         With BWB.Sheets(1)
    
21.             .UsedRange.Clear
    
22.             AWB.Sheets(1).Rows(1).Copy .Cells(1, 1) '表头
    
23.             .Cells(2, 1).CopyFromRecordset conn.Execute(Sql) '查询结果写入A2
    
24.             BWB.Save    '保存
    
25.             BWB.Close    '关闭
    
26.         End With
    
27.     Next i
    
28.     conn.Close
    
29.     Set conn = Nothing
    
30.     Set dic = Nothing
    
31.     Application.DisplayAlerts = True    '开启提醒
    
32.     Application.ScreenUpdating = True
    
33. End Sub
    

复制代码

孤独行星双星记

看看是不是我弄的这种结果？
在设置表中点击按钮即可。（小小BUG），由于最后一行中没有门店，但有数据）运行到最后的时候，那个工作簿不保存就行了。
拆分后的数据保存在拆分文件夹中。都是来帮你忙的，说话要讲文明呀。
或者在最后的那个汇总行，填写个门店（汇总），就不会出现对话框了。

sandy408

mineshine 发表于 2012-12-5 15:21

成功啦，太感谢了！！！！