表格拆分，工作簿里有三个表格

23366320

表格拆分，工作簿里有三个表格，格式不一样，希望保持格式不变，将表格按营服的名字拆分成多个工作簿，每个工作簿中都要有3个表格。命名按照营服中心来命名，如果可以自己加一些字段更好。

liulang0808

http://club.excelhome.net/thread-1385473-1-1.html
里面有拆分成单个表的案例，楼主可以参考下。。。
如果还有问题，请继续反馈

23366320

我是个小白，能帮忙做好吗？

lsc900707

多表同步拆分可参考8楼代码：
将表拆分文件和汇总
http://club.excelhome.net/thread-1428140-1-1.html
(出处: ExcelHome技术论坛)

ione_fox

10年注册， 还是小白。

23366320

呵呵.VBA完全摸不着头脑

23366320

最主要是10年没搞这个事情了，突然又倒回去要搞这个事情。

ione_fox

1. Option Explicit
   
2. 
   
3. Sub Test()
   
4.     Dim WB As Workbook
   
5.     Dim DicSht, DicWB
   
6.     Dim Path$, I&
   
7.     Set DicSht = CreateObject("Scripting.Dictionary")
   
8.     Set DicWB = CreateObject("Scripting.Dictionary")
   
9.     Set WB = ThisWorkbook
   
10.     Path = ThisWorkbook.FullName
    
11.     '===========Sht===============
    
12.     For I = 1 To Sheets.Count
    
13.         DicSht(Sheets(I).Name) = I
    
14.     Next I
    
15.     '============WB==============
    
16.     Dim Ar()
    
17.     Ar = Sheet1.UsedRange
    
18.     For I = 2 To UBound(Ar)
    
19.         If DicWB(Ar(I, 1)) = "" Then
    
20.             DicWB(Ar(I, 1)) = I - 1
    
21.         End If
    
22.     Next I
    
23.     '=============================
    
24.     Application.SheetsInNewWorkbook = DicSht.Count
    
25.     Dim KeyWB, Sql$
    
26.     For Each KeyWB In DicWB.keys
    
27.         With Workbooks.Add
    
28.         Application.StatusBar = "正在生成" & KeyWB & "请等待 "
    
29.         For I = 1 To DicSht.Count
    
30.             Sheets(I).Name = DicSht.keys()(I - 1)
    
31.             Sql = "select * from [" & Path & "].[" & Sheets(I).Name & "$]"
    
32.             Sql = Sql & " where  营服中心 = '" & KeyWB & "'"
    
33.             Call SQL执行(Path, .Sheets(I), Sql)
    
34.         Next I
    
35.         
    
36.          .SaveAs Filename:=WB.Path & "" & KeyWB
    
37.          .Close
    
38.         End With
    
39.         
    
40.     Next
    
41.     Application.SheetsInNewWorkbook = 3
    
42. End Sub
    
43. Sub SQL执行(WbNamePath As String, Sht, SqlStr As String)
    
44.     Dim conn As Object, rst As Object
    
45.     Dim StrConn As String, strSQL As String
    
46.     Dim I As Integer, PathStr As String
    
47.     Set conn = CreateObject("ADODB.Connection")
    
48.     Set rst = CreateObject("ADODB.Recordset")
    
49.     On Error GoTo 出错提示
    
50.     PathStr = WbNamePath '设置工作簿的完整路径和名称
    
51.     Select Case Application.Version * 1 '设置连接字符串,根据版本创建连接
    
52.     Case Is <= 11 '03以下版本包含03
    
53.         StrConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & PathStr
    
54.     Case Is >= 12 '07以上版本包含07
    
55.         StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    
56.     End Select
    
57.     conn.Open StrConn '打开数据库链接
    
58.     strSQL = SqlStr '设置SQL查询语句
    
59.     Set rst = conn.Execute(strSQL) '执行查询，并将结果输出到记录集对象
    
60.     With Sht '对存放结果的工作表操作
    
61.        .Cells.ClearContents '清除全表内容
    
62.         For I = 0 To rst.Fields.Count - 1 '填写标题
    
63.             .Cells(1, I + 1) = rst.Fields(I).Name
    
64.         Next I
    
65.        .Range("A2").CopyFromRecordset rst
    
66.     End With
    
67.     rst.Close: conn.Close '关闭数据库连接
    
68.     Set conn = Nothing: Set rst = Nothing '释放对象变量
    
69.     Exit Sub
    
70. 出错提示:
    
71.     MsgBox Err.Description, , "雪山飞狐温馨提示"
    
72. End Sub
    

复制代码

ione_fox

附件请测试

23366320

ione_fox：我复制了你的代码，运行了没反映呀