求助大神：同一工作簿中多个工作表按指定字段拆分为多个工作簿

xiangtiange

将一个工作簿中的多个工作表，按照“省”一栏字段拆分为不同工作簿兵役对应省命名，拆分出来的每个工作簿中包括原始工作簿中含该字段的所有表格，请各位大神帮忙，万分感谢

有4地

EXCEL必备工具箱有这个功能，百度搜索EXCEL必备工具箱第一个就是。

abc123281

里面有四个表  不明白你要按照哪一个表来拆分  如果四个表都拆分   那岂不是有重名的了   

xiangtiange

四个表都要按照“省”字段拆分，拆分出来的工作簿是包含这四个表的，附件里有预期拆分效果

xiangtiange

abc123281 发表于 2018-4-26 16:31
里面有四个表  不明白你要按照哪一个表来拆分  如果四个表都拆分   那岂不是有重名的了

四个表都要按照“省”字段拆分，拆分出来的工作簿是包含这四个表的，附件里有预期拆分效果

abc123281

呵呵  没见过这样拆分的  而且你的表列数也不一样

opiona

1.     PathM = ThisWorkbook.Path & "\模板.xlsx"
   
2.     Rem 准备结果文件夹
   
3.     PathG = ThisWorkbook.Path & "\拆分结果"
   
4.     Set FSO = CreateObject("Scripting.FileSystemObject")
   
5.     If FSO.FolderExists(PathG) = True Then
   
6.         FSO.GetFolder(PathG).Delete   '//删除文件夹
   
7.     End If
   
8.     MkDir PathG    '//创建文件夹
   
9.    
   
10.     Set SHX = Worksheets("首页")
    
11.     Str_coon = "HDR=NO';Data Source =" & ThisWorkbook.FullName     '//OFFICE2003，2007 通用
    
12.    
    
13.     Sql = ""
    
14.     For IROW = 2 To SHX.Range("A100").End(3).Row
    
15.         If Sql <> "" Then Sql = Sql & " UNION ALL "
    
16.         Sql = Sql & " SELECT F" & SHX.Cells(IROW, 4).Value & " AS 省名"
    
17.         Sql = Sql & " FROM [" & SHX.Cells(IROW, 1).Value & "$A" & SHX.Cells(IROW, 2).Value + 1 & ":IT]"
    
18.         Sql = Sql & " WHERE NOT F" & SHX.Cells(IROW, 4).Value & " IS NULL AND LEN(F" & SHX.Cells(IROW, 4).Value & ")>0"
    
19.     Next
    
20.    
    
21.     Rem  先获取要拆分字段的不重复值
    
22.     StrSQL = "SELECT DISTINCT 省名"
    
23.     StrSQL = StrSQL & " FROM (" & Sql & ")"
    
24.     ARX = GET_SQL_To_Arr(StrSQL, Str_coon, False)  '//不重复姓名放入二维数组
    
25.    
    
26.     If ARX(0, 0) <> "" And ARX(0, 0) <> "Error" Then
    
27.         ICINT = UBound(ARX) + 1
    
28.         
    
29.         For X = 0 To ICINT - 1 '//循环每一个值
    
30.             Rem  提示信息，在状态栏显示
    
31.             Application.StatusBar = "需拆分总数：" & ICINT & " 个，当前是第：" & X + 1 & " 个，当前印厂名称是：" & ARX(X, 0)
    
32.             DoEvents
    
33.             
    
34.             Set WB = Workbooks.Open(PathM)
    
35.             Rem 查询对应数据
    
36.             For IROW = 2 To SHX.Range("A100").End(3).Row
    
37.                 StrSQL = "SELECT * "
    
38.                 StrSQL = StrSQL & " FROM [" & SHX.Cells(IROW, 1).Value & "$A" & SHX.Cells(IROW, 2).Value + 1 & ":" & SHX.Cells(IROW, 3).Value & "]"
    
39.                 StrSQL = StrSQL & " WHERE F" & SHX.Cells(IROW, 4).Value & "='" & ARX(X, 0) & "'"
    
40.                
    
41.                 SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, False)
    
42.                 If UBound(SQLARR, 1) > 0 Then  '//没有数据，在不保存
    
43.                     Rem  粘贴数据，保存文件
    
44.                     Set SHW = WB.Worksheets("" & SHX.Cells(IROW, 1).Value)
    
45.                     SHW.Range("A" & SHX.Cells(IROW, 2).Value + 1).Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR
    
46.                 End If
    
47.             Next
    
48.             WB.SaveAs Filename:=PathG & "" & ARX(X, 0) & ".XLSX"
    
49.             WB.Close True
    
50.         Next
    
51.     Else
    
52.         MsgBox "未发现拆分依据 需要的值！", vbInformation, "北极狐提示!!"
    
53.     End If

复制代码

补充内容 (2019-5-30 10:58):
有个bug 只有一行数据的提不出来
修改此句，加个：等号：If UBound(SQLARR, 1) >= 0 Then  '//没有数据，在不保存

opiona

OPIONA14885553.rar (549.14 KB, 下载次数: 273)

2018-4-26 17:17 上传

点击文件名下载附件

jc128

前几天做了一下，有事一直没有传上来。

LMY123

ADO多表同时拆分