多条件拆工作表

XXZSP2

请教大佬，附件工作表A列是部门，C列是人员，同一个部门包含一个或多个人员，能实现按部门名称命名创建一个新的工作簿，其中包含属于同一部门下的人员名称命名的工作表内容 这种拆分吗？求赐教，非常感谢！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.4.19
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set sh = ThisWorkbook.Sheets("汇总")
   
7.     bt = 2        '//标题行数
   
8.     col = 1
   
9.     With sh
   
10.         r = .Cells(Rows.Count, col).End(3).Row
    
11.         c = .UsedRange.Columns.Count
    
12.         arr = .[a1].Resize(r, c)
    
13.     End With
    
14.     For i = bt + 1 To UBound(arr)
    
15.         s = arr(i, col)
    
16.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
17.         d(s)(i) = Application.Index(arr, i)
    
18.     Next
    
19.     On Error Resume Next
    
20.     For Each k In d.keys
    
21.         sh.Copy
    
22.         Set wb = ActiveWorkbook
    
23.         m = d(k).Count
    
24.         With wb.Sheets(1)
    
25.             .Name = k
    
26.             .DrawingObjects.Delete
    
27.             .UsedRange.Offset(bt + m).Clear
    
28.             .Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).Items, 1)
    
29.         End With
    
30.         wb.SaveAs p & k
    
31.         wb.Close 1
    
32.     Next
    
33.     Set d = Nothing
    
34.     Application.ScreenUpdating = True
    
35.     MsgBox "拆分完毕！"
    
36. End Sub
    

复制代码

yanglinzi

不知是不是你要的结果

XXZSP2

ykcbf1100 发表于 2024-4-19 16:23
附件供参考。。。

非常感谢！不过我想如图那样，工作簿里再放按属于同一部门下的人员名称命名的独立工作表内容，谢谢！

baofa2

1. Sub test1()
   
2.   Dim dict As Object, ar, i As Long, j As Long, k
   
3.   Dim p As String, s As String, t As String, pos As Long
   
4.   DoApp False
   
5.   pos = 2
   
6.   p = ThisWorkbook.Path & "\分簿分表"
   
7.   If Dir(p, vbDirectory) = "" Then MkDir p
   
8.   Set dict = CreateObject("Scripting.Dictionary")
   
9.   With ActiveSheet
   
10.     '.UsedRange.Offset(pos).UnMerge  '若有错，用上此句
    
11.     ar = .Range("A1").CurrentRegion.Value
    
12.     j = UBound(ar, 2)
    
13.     For i = pos + 1 To UBound(ar)
    
14.       s = ar(i, 1)
    
15.       t = ar(i, 3)
    
16.       If Not dict.Exists(s) Then Set dict(s) = CreateObject("Scripting.DictionAry")
    
17.       If Not dict(s).Exists(t) Then Set dict(s)(t) = .Range("A1").Resize(pos, j)
    
18.       Set dict(s)(t) = Union(dict(s)(t), .Range("A" & i).Resize(, j))
    
19.     Next
    
20.   End With
    
21.   For Each k In dict.Keys
    
22.     Application.SheetsInNewWorkbook = dict(k).Count
    
23.     With Workbooks.Add
    
24.       For j = 0 To dict(k).Count - 1
    
25.         With .Worksheets(j + 1)
    
26.           dict(k).Items()(j).Copy .Range("A1")
    
27.           .Name = dict(k).Keys()(j)
    
28.         End With
    
29.       Next
    
30.       .SaveAs p & "\" & k, 51
    
31.       .Close
    
32.     End With
    
33.   Next
    
34.   Set dict = Nothing
    
35.   Application.SheetsInNewWorkbook = 1
    
36.   DoApp
    
37.   Beep
    
38. End Sub
    
39. 
    
40. Function DoApp(Optional b As Boolean = True)
    
41.   With Application
    
42.     .ScreenUpdating = b
    
43.     .DisplayAlerts = b
    
44.     .Calculation = -b * 30 - 4135
    
45.   End With
    
46. End Function

复制代码

ykcbf1100

XXZSP2 发表于 2024-4-19 16:50
非常感谢！不过我想如图那样，工作簿里再放按属于同一部门下的人员名称命名的独立工作表内容，谢谢！

改好了。。。

ykcbf1100

代码更新，3级字典。。。

1. Sub ykcbf()   '//2024.4.19
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set Sh = ThisWorkbook.Sheets("汇总")
   
7.     bt = 2        '//标题行数
   
8.     col = 1
   
9.     With Sh
   
10.         r = .Cells(Rows.Count, col).End(3).Row
    
11.         c = .UsedRange.Columns.Count
    
12.         arr = .[a1].Resize(r, c)
    
13.     End With
    
14.     For i = bt + 1 To UBound(arr)
    
15.         s = arr(i, col): ss = arr(i, 3)
    
16.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
17.         If Not d(s).exists(ss) Then Set d(s)(ss) = CreateObject("Scripting.Dictionary")
    
18.         d(s)(ss)(i) = Application.Index(arr, i)
    
19.     Next
    
20.     On Error Resume Next
    
21.     For Each k In d.keys
    
22.         Sh.Copy
    
23.         Set wb = ActiveWorkbook
    
24.         n = 0
    
25.         For Each kk In d(k).keys
    
26.             n = n + 1
    
27.             m = d(k)(kk).Count
    
28.             If n = 1 Then
    
29.                 Set sht = wb.Sheets(1)
    
30.             Else
    
31.                 Sh.Copy After:=wb.Sheets(wb.Sheets.Count)
    
32.                 Set sht = wb.Sheets(wb.Sheets.Count)
    
33.             End If
    
34.             With sht
    
35.                 .Name = kk
    
36.                 .DrawingObjects.Delete
    
37.                 .UsedRange.Offset(bt + m).Clear
    
38.                 .Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k)(kk).Items, 1)
    
39.             End With
    
40.         Next
    
41.         wb.SaveAs p & k
    
42.         wb.Close 1
    
43.     Next
    
44.     Set d = Nothing
    
45.     Application.ScreenUpdating = True
    
46.     MsgBox "拆分完毕！"
    
47. End Sub
    

复制代码

蓝桥玄霜

分表的例子：

limonet

本想用SQL，但楼主不一定支持，算了。