如何根据多个工作表中指定字段拆分工作表为相应工作簿对应工作表和统计表

yzyyyyyyy

工作簿中有多个源工作表，目前事例中有两个工作表，一个统计表

这两个工作表中，有相同的字段班级，但不一定在同一列，根据班级列拆分工作表；照顾对象工作表中，另有一个关键列（类别），生成统计表用；特长生工作表中，另有一个关键列（报考专业），生成统计表用。
统计表：分班级统计，工作表名，关键列（类别，报考专业）人数
以班级列为关键字段拆分，统计班级，工作表名，关键列（类别，报考专业）人数。生成班级工作簿到成品文件中。
样例中，1班为成品样本。 如何根据多个工作表中指定字段拆分工作表为相应工作簿对应工作表和统计表.rar (6.99 KB, 下载次数: 11)

2024-5-8 20:16 上传

点击文件名下载附件

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.5.8
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim t: t = Timer
   
5.     Dim d As Object, rng As Range
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set ws = ThisWorkbook
   
8.     Set sh = ThisWorkbook.Sheets("统计表")
   
9.     p = ThisWorkbook.Path & "\成品"
   
10.     For Each sht In ws.Sheets
    
11.         If sht.Name <> sh.Name Then
    
12.             arr = sht.UsedRange
    
13.             c = Application.WorksheetFunction.Match("班级", sht.Rows(1), 0)
    
14.             For i = 2 To UBound(arr)
    
15.                 s = arr(i, c)
    
16.                 If s <> "" Then d(s) = ""
    
17.             Next i
    
18.         End If
    
19.     Next sht
    
20.     For Each k In d.keys
    
21.         ws.Sheets.Copy
    
22.         Set wb = ActiveWorkbook
    
23.         For Each sht In wb.Sheets
    
24.             If sht.Name <> sh.Name Then
    
25.                 With sht
    
26.                     arr = .UsedRange
    
27.                     c = Application.WorksheetFunction.Match("班级", sht.Rows(1), 0)
    
28.                     For i = 2 To UBound(arr)
    
29.                         If arr(i, c) <> k Then
    
30.                             If rng Is Nothing Then
    
31.                                 Set rng = .Rows(i)
    
32.                             Else
    
33.                                 Set rng = Union(rng, .Rows(i))
    
34.                             End If
    
35.                         End If
    
36.                     Next i
    
37.                     If Not rng Is Nothing Then rng.Delete
    
38.                     Set rng = Nothing
    
39.                 End With
    
40.             End If
    
41.         Next
    
42.         With wb.Sheets(sh.Name)
    
43.             .[b1] = k
    
44.             .[b7] = k
    
45.             .DrawingObjects.Delete
    
46.         End With
    
47.         wb.SaveAs p & k & "班", 56
    
48.         wb.Close
    
49.     Next k
    
50.     Application.ScreenUpdating = True
    
51.     Application.DisplayAlerts = True
    
52.     MsgBox "拆分完毕，共用时： " & Format(Timer - t, "0.000秒"), , "提示"
    
53. End Sub
    

复制代码