ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
数据管理利器Foxtable2022下载 Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 Power Query数据清洗实战攻略 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 173|回复: 14

[求助] 拆分工作表

[复制链接]

TA的精华主题

TA的得分主题

发表于 2021-10-13 15:22 | 显示全部楼层 |阅读模式
小白一个,学习了很久搞不定,又来求助老师们了,根据花名册模板,把花名册里面的内容按班组分类拆分成工作表

工作簿2.zip

23.9 KB, 下载次数: 23

TA的精华主题

TA的得分主题

发表于 2021-10-13 15:39 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2021-10-13 15:45 | 显示全部楼层
除了二楼的   就是用那个INDEX+IF+SMALL+ROW组合公式来搞

TA的精华主题

TA的得分主题

 楼主| 发表于 2021-10-13 16:33 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2021-10-13 16:34 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2021-10-13 16:53 | 显示全部楼层

因为电脑问题,无法上传附件,如下代码供楼主参考
  1. Option Explicit

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

评分

参与人数 1鲜花 +2 收起 理由
xiangheping + 2 太强大了

查看全部评分

TA的精华主题

TA的得分主题

发表于 2021-10-13 17:35 | 显示全部楼层
格式没有调。H列排序好了才能用本方法。新手试水

工作簿2.zip

31.64 KB, 下载次数: 5

TA的精华主题

TA的得分主题

发表于 2021-10-13 17:44 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2021-10-13 18:18 | 显示全部楼层
  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
复制代码

TA的精华主题

TA的得分主题

发表于 2021-10-13 18:20 | 显示全部楼层
测试参考附件:

工作簿1013.rar

74.45 KB, 下载次数: 12

评分

参与人数 1鲜花 +2 收起 理由
xiangheping + 2 太强大了

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,高效办公专列,每天发车

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2021-10-25 06:24 , Processed in 0.109074 second(s), 19 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表