按部门把总表拆分各个表格

284136140

按部门把总表拆分各个表格

abc123281

1. Sub 拆分()
   
2.   Dim arr
   
3.   Dim wb As Workbook
   
4.   Application.ScreenUpdating = False
   
5.   Application.DisplayAlerts = False
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   With Worksheets("出库单")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("a1:u" & r)
   
10.     For i = 2 To UBound(arr)
    
11.       If Not d.exists(arr(i, 21)) Then
    
12.         Set d(arr(i, 21)) = .Cells(1, 1).Resize(1, 21)
    
13.       Else
    
14.         Set d(arr(i, 21)) = Union(d(arr(i, 21)), .Cells(i, 1).Resize(1, 21))
    
15.       End If
    
16.     Next
    
17.   End With
    
18.   For Each aa In d.keys
    
19.     Set wb = Workbooks.Add
    
20.     With wb
    
21.        With .Worksheets(1)
    
22.           d(aa).Copy .Range("a1")
    
23.          .Name = aa & "部门"
    
24.        End With
    
25.       .SaveAs Filename:=ThisWorkbook.Path & "\各部门信息" & aa & "部门"
    
26.       .Close False
    
27.     End With
    
28.   Next
    
29.   Application.ScreenUpdating = True
    
30.   MsgBox "数据拆分完毕！"
    
31. End Sub

复制代码

abc123281

2018年3月出库abc123.rar (62.81 KB, 下载次数: 221)

2018-4-1 23:42 上传

点击文件名下载附件

284136140

abc123281 发表于 2018-4-1 23:42

谢谢啦！
但是我想把它拆分在同一张工作簿里，多张工作表。不要拆分怎么成怎么多工作薄。

abc123281

可以啊  随便改一下就行

abc123281

1. Sub 拆分()
   
2.   Dim arr
   
3.   Dim ws As Worksheet
   
4.   Application.ScreenUpdating = False
   
5.   Application.DisplayAlerts = False
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   With Worksheets("出库单")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("a1:u" & r)
   
10.     For i = 2 To UBound(arr)
    
11.       If Not d.exists(arr(i, 21)) Then
    
12.         Set d(arr(i, 21)) = .Cells(1, 1).Resize(1, 21)
    
13.       Else
    
14.         Set d(arr(i, 21)) = Union(d(arr(i, 21)), .Cells(i, 1).Resize(1, 21))
    
15.       End If
    
16.     Next
    
17.   End With
    
18.   For Each aa In d.keys
    
19.     Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
20.     With ws
    
21.        d(aa).Copy .Range("a1")
    
22.       .Name = aa & "部门"
    
23.     End With
    
24.   Next
    
25.    Worksheets("出库单").Activate
    
26.   Application.ScreenUpdating = True
    
27.   MsgBox "数据拆分完毕！"
    
28. End Sub

复制代码

abc123281

2018年3月出库 拆分在一个工作簿.rar (63.16 KB, 下载次数: 168)

2018-4-2 23:17 上传

点击文件名下载附件

284136140

abc123281 发表于 2018-4-2 23:17

我发现 拆分出来后比如业务部门1销售总金额 会不等于总表业务部门1的销售总金额，好像都是差每个部门第一行的金额

284136140

abc123281 发表于 2018-4-2 23:17

拆分出来后，比如业务部门1的销售总金额，不等于总表业务部门1的销售总金额，好像都是差每个部门第一行销售金额。