把汇总表的考勤工时明细复制到模板中

leihs

各位大神，我想把从考勤系统导出来的考勤工时明细按人名取到模板中，即从“考勤总表”中取第3行的数据到“项目模板”的B行，并分别按人名保存为新表格待做参与研发项目的工时分配。用AI处理了效果不理想，特来此处求助各大神们！

半百

不上附件等于白说

leihs

不好意思，忘记了，已上传

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf2()  '//2024.4.12
   
2.     Dim arr, brr, d
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Dim tm: tm = Timer
   
7.     Set ws = ThisWorkbook
   
8.     Set sh = ws.Sheets("考勤总表")
   
9.     bt = 2
   
10.     For Each sht In Sheets
    
11.         If sht.Name <> sh.Name And sht.Name <> "项目模版" Then sht.Delete
    
12.     Next
    
13.     arr = sh.UsedRange
    
14.     For i = bt + 1 To UBound(arr)
    
15.         s = arr(i, 2)
    
16.         If Not d.Exists(s) Then
    
17.             Set d(s) = CreateObject("scripting.dictionary")
    
18.         End If
    
19.         d(s)(i) = i
    
20.     Next i
    
21.     On Error Resume Next
    
22.     For Each k In d.keys
    
23.         Sheets("项目模版").Copy after:=Sheets(Sheets.Count)
    
24.         Set sht = Sheets(Sheets.Count)
    
25.         m = 0
    
26.         With sht
    
27.             .Name = k
    
28.             .[b2] = k
    
29.             ReDim brr(1 To 31, 1 To 1)
    
30.             For Each kk In d(k).keys
    
31.                 r = kk
    
32.                 For j = 4 To UBound(arr, 2) - 1
    
33.                     m = m + 1
    
34.                     brr(m, 1) = arr(r, j)
    
35.                 Next
    
36.             Next
    
37.             .[b5].Resize(31, 1) = brr
    
38.             .[h2] = arr(r, 3)
    
39.         End With
    
40.     Next k
    
41.     sh.Activate
    
42.     Set d = Nothing
    
43.     Application.DisplayAlerts = True
    
44.     Application.ScreenUpdating = True
    
45.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
46. End Sub
    

复制代码

牛牛神哦

你好，请试用一下是否可以，有问题再沟通。

gwjkkkkk

Option Explicit
Sub test1()
    Dim ar, br, i&, j&, wks As Worksheet
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    ar = Range("A2", Cells(Rows.Count, "AH").End(xlUp)).Value
    ReDim br(1 To 31, 1 To 2)
    Set wks = Worksheets("项目模版")
   
    With Workbooks.Add
        For i = 2 To UBound(ar)
           wks.Copy after:=.Worksheets(.Worksheets.Count)
           With ActiveSheet
                .Name = ar(i, 2)
                .Cells(2, 2) = ar(i, 2)
                .Cells(2, 8) = ar(i, 3)
                .Cells(39, 4) = ar(i, 2)
                For j = 1 To UBound(br)
                    br(j, 1) = ar(1, j + 3)
                    br(j, 2) = ar(i, j + 3)
                Next j
                .Cells(5, 1).Resize(31, 2) = br ' ar(i, 9)
            End With
        Next
        For Each wks In .Worksheets
            If wks.Name Like "*Sheet*" Then wks.Delete
        Next
    End With
    Call CreateList
   
    Set wks = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Beep
End Sub

Sub CreateList()
    Dim i&
   
    Worksheets.Add(before:=Worksheets(1)).Name = "工作表目录"
    [A1].Resize(, 2) = [{"序号", "姓名"}]
    For i = 2 To Worksheets.Count
        Cells(i, 1).Value = i - 1
        ActiveSheet.Hyperlinks.Add Cells(i, 2), "", "'" & Worksheets(i).Name & "'" & "!A1", _
        "单击打开：" & Worksheets(i).Name, Worksheets(i).Name
        
        Worksheets(i).Hyperlinks.Add Worksheets(i).Cells(1, 1), "", _
        Worksheets(1).Name & "!B" & i, "返回目录"
        With Worksheets(i).Cells(1, 1)
            .Font.Size = 22
            .Font.Bold = True
        End With
    Next i
   
    Columns("A:D").AutoFit
End Sub

gwjkkkkk

参与一下。。。

sunya_0529

WPS里的JSA练习一下——

leihs

谢谢各位大神，我逐个试后反馈