|
因为电脑问题,无法上传附件,如下代码供楼主参考- Option Explicit
- Sub chaf()
- Application.DisplayAlerts = False
- Dim dic, con, rs, sql$, n%, arr, k, sh
- For Each sh In Worksheets
- If sh.Name = "花名册" Or sh.Name = "花名册模板" Then
- Else
- sh.Delete
- End If
- Next
- Set dic = CreateObject("scripting.dictionary")
- Worksheets("花名册").Activate
- arr = Range("h2:h" & Cells(Rows.Count, 8).End(xlUp).Row)
- For n = 1 To UBound(arr, 1)
- dic(arr(n, 1)) = ""
- Next
- Set con = CreateObject("adodb.connection")
- Set rs = CreateObject("adodb.recordset")
- con.Open "provider=microsoft.ace.oledb.12.0;" _
- & "extended properties=excel 12.0;" _
- & "data source=" & ThisWorkbook.FullName
- For Each k In dic.keys
- sql = "select 姓名,性别,民族,籍贯,身份证,身份证地址,联系电话,工种,进场时间,退场时间 from [花名册$] where 班组='" & k & "'"
- rs.Open sql, con, 1, 3
- Worksheets("花名册模板").Copy after:=Worksheets(Worksheets.Count)
- Set sh = ActiveSheet
- sh.Name = "花名册模板" & "-" & k
- sh.[b6].CopyFromRecordset rs
- rs.Close
- Next
- con.Close
- Set rs = Nothing
- Set con = Nothing
- Application.DisplayAlerts = True
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|