VBA自动根据部门拆分工作表

BTS7V

请大神们写个代码，用表格中的汇总表数据，根据部门字段拆分成不同的工作簿，工作簿名称用部门名称表示。表头的项目1 项目2等名称可能会修改。

不知道为什么

拆分的代码很多哦，自己找着练练手

opiona

1.     Set SHX = Worksheets("汇总")
   
2.     PathG = ThisWorkbook.Path & "\拆分结果"  '//结果文件夹
   
3.     Set FSO = CreateObject("Scripting.FileSystemObject")
   
4.     If FSO.FolderExists(PathG) = True Then
   
5.         FSO.GetFolder(PathG).Delete   '//删除文件夹
   
6.     End If
   
7.     MkDir PathG    '//创建文件夹
   
8. 
   
9.     Rem  模板中放置数据的单元格位置，和查询标题对应
   
10.     StrBT = ""
    
11.     For ICOL = 1 To SHX.Range("IT1").End(xlToLeft).Column
    
12.         If StrBT <> "" Then StrBT = StrBT & ","
    
13.         StrBT = StrBT & "[" & SHX.Cells(1, ICOL).Value & "]"
    
14.     Next
    
15.    
    
16.     Str_coon = "HDR=yes';Data Source =" & ThisWorkbook.FullName     '//OFFICE2003，2007 通用
    
17.     Rem  先获取要拆分字段的不重复值
    
18.     StrSQL = "SELECT DISTINCT [部门]"
    
19.     StrSQL = StrSQL & " FROM [" & SHX.Name & "$A1:IT]"
    
20.     StrSQL = StrSQL & " WHERE NOT [部门] IS NULL AND LEN([部门])>0"
    
21.    
    
22.     ARX = GET_SQL_To_Arr(StrSQL, Str_coon, False)  '//不重复姓名放入二维数组
    
23.     If ARX(0, 0) <> "" And ARX(0, 0) <> "Error" Then
    
24.         ICINT = UBound(ARX) + 1
    
25.         For X = 0 To ICINT - 1 '//循环每一个值
    
26.             
    
27.             Rem  提示信息，在状态栏显示
    
28.             Application.StatusBar = "需拆分总数：" & ICINT & " 个，当前是第：" & X + 1 & " 个，当前部门是：" & ARX(X, 0)
    
29.             DoEvents
    
30.             
    
31.             Rem 查询对应数据
    
32.             StrSQL = ""
    
33.             StrSQL = StrSQL & "SELECT " & StrBT
    
34.             StrSQL = StrSQL & " FROM [" & SHX.Name & "$A1:IT]"
    
35.             StrSQL = StrSQL & " WHERE [部门]='" & ARX(X, 0) & "'"
    
36.             SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, True)
    
37.             If SQLARR(0, 0) <> "" And SQLARR(0, 0) <> "Error" Then '//没有数据，在不保存
    
38.                 Set WB = Workbooks.Add
    
39.                 Set SHW = Worksheets(1)
    
40.                 SHW.Name = "汇总"
    
41.                 SHW.Range("A1").Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR
    
42.                 WB.SaveAs Filename:=PathG & "" & ARX(X, 0) & ".XLS", FileFormat:=xlExcel8
    
43.                 WB.Close True
    
44.             End If
    
45.         Next
    
46.     Else
    
47.         MsgBox "未发现拆分依据 需要的值！", vbInformation, "北极狐提示!!"
    
48.     End If

复制代码

opiona

自动拆分(1).rar (25.14 KB, 下载次数: 279)

2018-7-7 13:29 上传

点击文件名下载附件

不知道为什么

如图            

不知道为什么

代码如图，供测试

BTS7V

opiona 发表于 2018-7-7 13:29

可以有详细操作步骤吗

lsc900707

Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = [a1].CurrentRegion
    m = UBound(arr): n = UBound(arr, 2)
    Set rng = Rows(1)
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To m
         If Not d.exists(arr(i, 3)) Then
                Set d(arr(i, 3)) = Cells(i, 1).Resize(1, n)
            Else
                Set d(arr(i, 3)) = Union(d(arr(i, 3)), Cells(i, 1).Resize(1, n))
         End If
    Next
    k = d.keys: t = d.items
    For i = 0 To d.Count - 1
        Set wb = Workbooks.Add(xlWBATWorksheet)
        With wb.Sheets(1)
            rng.Copy .[a1]: t(i).Copy .[a2]
            For j = 1 To UBound(arr, 2)
               .Columns(j).ColumnWidth = ThisWorkbook.ActiveSheet.Columns(j).ColumnWidth
            Next
        End With
        wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k(i), FileFormat:=xlExcel8
        wb.Close
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

lsc900707

参考附件：

opiona

BTS7V 发表于 2018-7-7 13:59
可以有详细操作步骤吗

附件都是做好的啊！