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

ykcbf1100

纯练手，总表拆分为多表，2级字典。

ykcbf1100

代码调试通过。。。

1. Sub ykcbf()   '//2024.2.3  总表按部门拆分为多表
   
2.     Dim wb, arr, sh
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Dim tm: tm = Timer
   
6.     Set fso = CreateObject("Scripting.FileSystemObject")
   
7.     Set d = CreateObject("Scripting.Dictionary")
   
8.     p = ThisWorkbook.Path & ""
   
9.     p1 = p & "各部门信息"
   
10.     If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
11.     Set ws = ThisWorkbook
    
12.     Set sh = ws.Sheets("出库单")
    
13.     On Error Resume Next
    
14.     For Each sht In ws.Sheets
    
15.         If sht.Name <> sh.Name Then sht.Delete
    
16.     Next
    
17.     arr = sh.UsedRange
    
18.     For i = 2 To UBound(arr)
    
19.         s = CStr(arr(i, 21))
    
20.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
21.         d(s)(i) = i
    
22.     Next
    
23.     For Each k In d.keys
    
24.         sh.Copy after:=Sheets(Sheets.Count)
    
25.         Set sht = Sheets(Sheets.Count)
    
26.         m = 0
    
27.         ReDim brr(1 To d(k).Count, 1 To UBound(arr, 2))
    
28.         With sht
    
29.             .Name = k & "部门"
    
30.             .DrawingObjects.Delete
    
31.             .UsedRange.Offset(1 + d(k).Count).Clear
    
32.             For Each kk In d(k).keys
    
33.                 m = m + 1
    
34.                 For j = 1 To UBound(arr, 2)
    
35.                     brr(m, j) = arr(kk, j)
    
36.                 Next
    
37.             Next
    
38.             .[a2].Resize(m, UBound(brr, 2)) = brr
    
39.         End With
    
40.     Next
    
41.     sh.Activate
    
42.     Set d = Nothing
    
43.     Application.ScreenUpdating = True
    
44.     MsgBox "拆分完毕，共用时：" & Format(Timer - tm) & "秒！"
    
45. End Sub
    

复制代码

ykcbf1100

再练手。

总表拆分为多工作簿。

ykcbf1100

代码调试通过。。。

1. Sub ykcbf()   '//2024.2.3  总表按部门拆分为多工作簿
   
2.     Dim wb, arr, sh
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Dim tm: tm = Timer
   
6.     Set fso = CreateObject("Scripting.FileSystemObject")
   
7.     Set d = CreateObject("Scripting.Dictionary")
   
8.     p = ThisWorkbook.Path & ""
   
9.     p1 = p & "各部门信息"
   
10.     If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
11.     Set ws = ThisWorkbook
    
12.     Set sh = ws.Sheets("出库单")
    
13.     On Error Resume Next
    
14.     arr = sh.UsedRange
    
15.     For i = 2 To UBound(arr)
    
16.         s = CStr(arr(i, 21))
    
17.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
18.         d(s)(i) = i
    
19.     Next
    
20.     For Each k In d.keys
    
21.         sh.Copy
    
22.         Set wb = ActiveWorkbook
    
23.         m = 0
    
24.         ReDim brr(1 To d(k).Count, 1 To UBound(arr, 2))
    
25.         With wb.Sheets(1)
    
26.             .Name = k & "部门"
    
27.             .DrawingObjects.Delete
    
28.             .UsedRange.Offset(1 + d(k).Count).Clear
    
29.             For Each kk In d(k).keys
    
30.                 m = m + 1
    
31.                 For j = 1 To UBound(arr, 2)
    
32.                     brr(m, j) = arr(kk, j)
    
33.                 Next
    
34.             Next
    
35.             .[a2].Resize(m, UBound(brr, 2)) = brr
    
36.         End With
    
37.         wb.SaveAs p1 & k & "部门"
    
38.         wb.Close
    
39.     Next
    
40.     Set d = Nothing
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "拆分完毕，共用时：" & Format(Timer - tm) & "秒！"
    
43. End Sub
    

复制代码