拆分工作表

xiangheping

小白一个，学习了很久搞不定，又来求助老师们了，根据花名册模板，把花名册里面的内容按班组分类拆分成工作表

phanmin

要用VBA，不然就筛选，复制，粘贴

吾股丰登

除了二楼的   就是用那个INDEX+IF+SMALL+ROW组合公式来搞

xiangheping

吾股丰登 发表于 2021-10-13 15:45
除了二楼的   就是用那个INDEX+IF+SMALL+ROW组合公式来搞

想用vba解决

xiangheping

phanmin 发表于 2021-10-13 15:39
要用VBA，不然就筛选，复制，粘贴

想用vba

xuqing8331

xiangheping 发表于 2021-10-13 16:34
想用vba

因为电脑问题，无法上传附件，如下代码供楼主参考

1. Option Explicit
   
2. 
   
3. Sub chaf()
   
4. Application.DisplayAlerts = False
   
5. Dim dic, con, rs, sql$, n%, arr, k, sh
   
6. For Each sh In Worksheets
   
7.     If sh.Name = "花名册" Or sh.Name = "花名册模板" Then
   
8.     Else
   
9.         sh.Delete
   
10.     End If
    
11. Next
    
12. Set dic = CreateObject("scripting.dictionary")
    
13. Worksheets("花名册").Activate
    
14. arr = Range("h2:h" & Cells(Rows.Count, 8).End(xlUp).Row)
    
15. For n = 1 To UBound(arr, 1)
    
16.     dic(arr(n, 1)) = ""
    
17. Next
    
18. Set con = CreateObject("adodb.connection")
    
19. Set rs = CreateObject("adodb.recordset")
    
20. con.Open "provider=microsoft.ace.oledb.12.0;" _
    
21. & "extended properties=excel 12.0;" _
    
22. & "data source=" & ThisWorkbook.FullName
    
23. For Each k In dic.keys
    
24.     sql = "select 姓名,性别,民族,籍贯,身份证,身份证地址,联系电话,工种,进场时间,退场时间 from [花名册$] where 班组='" & k & "'"
    
25.     rs.Open sql, con, 1, 3
    
26.     Worksheets("花名册模板").Copy after:=Worksheets(Worksheets.Count)
    
27.     Set sh = ActiveSheet
    
28.     sh.Name = "花名册模板" & "-" & k
    
29.     sh.[b6].CopyFromRecordset rs
    
30.     rs.Close
    
31. Next
    
32. con.Close
    
33. Set rs = Nothing
    
34. Set con = Nothing
    
35. Application.DisplayAlerts = True
    
36. End Sub

复制代码

不规则结构

格式没有调。H列排序好了才能用本方法。新手试水

lisongmei

仅供参考

lsc900707

1. Sub gj23w98()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     For Each sht In Sheets
   
6.         If sht.Name <> "花名册" And sht.Name <> "花名册模板" Then sht.Delete
   
7.     Next
   
8.     Application.DisplayAlerts = True
   
9.     arr = [a1].CurrentRegion
   
10.     ReDim brr(1 To UBound(arr), 1 To 11)
    
11.     For i = 2 To UBound(arr)
    
12.         d(arr(i, 8)) = ""
    
13.     Next
    
14.     k = d.keys
    
15.     For i = 0 To UBound(k)
    
16.         m = 0
    
17.         For n = 1 To UBound(arr)
    
18.             If arr(n, 8) = k(i) Then
    
19.                 m = m + 1
    
20.                 brr(m, 1) = m
    
21.                 brr(m, 2) = arr(n, 1)
    
22.                 brr(m, 3) = arr(n, 2)
    
23.                 brr(m, 4) = arr(n, 4)
    
24.                 brr(m, 5) = arr(n, 3)
    
25.                 brr(m, 6) = arr(n, 5)
    
26.                 brr(m, 7) = arr(n, 13)
    
27.                 brr(m, 8) = arr(n, 6)
    
28.                 For j = 9 To 11
    
29.                     brr(m, j) = arr(n, j)
    
30.                 Next
    
31.             End If
    
32.         Next
    
33.         Sheets("花名册模板").Copy After:=Sheets(Worksheets.Count)
    
34.         With ActiveSheet
    
35.             .Name = k(i)
    
36.             .[c4] = k(i)
    
37.             .[a6].Resize(m, 11) = brr
    
38.         End With
    
39.         Sheets("花名册").Activate
    
40.      Next
    
41.      Application.ScreenUpdating = True
    
42.      MsgBox "OK！"
    
43. End Sub

复制代码

lsc900707

测试参考附件：