请教怎么根据模板表格和数据源，批量生成单个工作簿？

lover826

怎么根据模板表格和数据源，批量生成单个工作簿？如下图，我要按我的模板，依据日期生成100个或者1000个单独工作簿。生成的工作簿保存的时候命名最好带有日期（或者在数据源内的再加一列作为命名名称都行），麻烦知道的大师教一下，谢谢！


请帮忙做的表.rar (19.77 KB, 下载次数: 27)

2022-11-19 17:47 上传

点击文件名下载附件

捞屎人

djp1018

捞屎人 发表于 2022-11-19 18:52

Public Sub 选择科目()
   Application.ScreenUpdating = False
   Set stp1 = Worksheets("数据源") 'stp1指向学生数据sheet
   Set stp2 = Worksheets("统计表") 'stp2指向监考sheet
   Set Rng = stp2.Cells(1).CurrentRegion
   Set dic = CreateObject("scripting.dictionary") '建立关键字的字典
   For i = 2 To UBound(arr)
      If Not dic.exists(arr(i, 1) & "") Then
           ReDim brr(1 To arr(i, 5), 1 To 4)
           For j = 1 To arr(i, 5)
               brr(j, 1) = arr(i, 1): brr(j, 2) = arr(i, 3): brr(j, 3) = arr(i, 4)
           Next
           Set wb = Application.Workbooks.Add '指向新建工作簿
           With wb
                .SaveAs Filename:=ThisWorkbook.Path & "\" & Replace(arr(i, 1), "/", "-") & ".xlsx", ReadOnlyRecommended:=1
                Set shtp = 复制工作表(stp2, Replace(arr(i, 1), "/", "-"), wb)
                shtp.Cells(5, 1).Resize(arr(i, 5), 4) = brr
                .Close False
            End With
        End If
    Next
End Sub
Public Function 复制工作表(stp As Worksheet, st$, Optional wb = Nothing) '将stp工作表复制到wb工作薄并重命名为st
    Application.DisplayAlerts = False '关闭警告提示
    If wb Is Nothing Then Set wb = stp.Parent
    With wb
         stp.Copy After:=Worksheets(Worksheets.Count) '复制工作表
         On Error Resume Next '忽略错误继续执行VBA代码,避免出现错误消息
mingming2:
         Err.Clear
         ActiveSheet.Name = st '重命名
         If Err.Nunber = 1004 Then '如果重命名失败,即说明工作表存在,则删除
            .Worksheets(st).Delete '删除st工作表
            GoTo mingming2
         End If
         On Error GoTo 0 '以下恢复捕捉代码出现错误消息
         '.Worksheets(st).Tab.ColorIndex = 3 '工作表标签红色
         Set 复制工作表 = .Worksheets(st) '返回新建工作表
     End With
     Application.DisplayAlerts = True '打开警告提示
End Function

djp1018

捞屎人 发表于 2022-11-19 18:52

老师：运行不起呢？

捞屎人

djp1018 发表于 2022-11-19 22:21
老师：运行不起呢？

黄色那一句改一下

lover826

捞屎人 发表于 2022-11-19 18:52

可以对照我那个帮忙做一下吗？感谢！

捞屎人

lover826 发表于 2022-11-21 17:33
可以对照我那个帮忙做一下吗？感谢！

当志愿者了  一个星期内摸不到电脑  爱莫能助

lover826

捞屎人 发表于 2022-11-21 17:55
当志愿者了  一个星期内摸不到电脑  爱莫能助

哦哦，你这个模板的原始文档看看，是怎么个逻辑？

limonet

这个不难，难在我没有理解“2022-01-01走了2户吗“？