【急！】如何从一个Excel表中提取数据，自动填入指定模板，生成多个Excel文件？

紫寒100

今天好像回复不了了，就是把04专业表按模板拆分成工作簿

紫寒100

z9bhd 发表于 2021-3-27 13:23
附件下载看了一下，没搞懂你的意思，建议单发一贴让高手帮你看看

不好意思，今天先前一直回复不了，就是把04那张表按照项目名称按模板拆分成单独的工作簿

紫寒100

z9bhd 发表于 2021-3-27 13:23
附件下载看了一下，没搞懂你的意思，建议单发一贴让高手帮你看看

单发我担心没人看就沉下去了，我的意思就是只拆分04表，把04表按项目名称按模板格式拆分成单独的工作簿，一个项目一个工作簿，其他的表不能删除，我找到的代码，会删除其他表，

z9bhd

紫寒100 发表于 2021-3-27 20:47
不好意思，今天先前一直回复不了，就是把04那张表按照项目名称按模板拆分成单独的工作簿

我这里网络也是刚刚才修好，你能不能先发个模拟效果？这样才好理解你到底是想达到什么目标，没理解你的意思就没办法写代码

z9bhd

紫寒100 发表于 2021-3-27 20:52
单发我担心没人看就沉下去了，我的意思就是只拆分04表，把04表按项目名称按模板格式拆分成单独的工作簿， ...

模板里的姓名、分配比例、分配金额要怎么对应？

z9bhd

z9bhd 发表于 2021-3-27 21:19
模板里的姓名、分配比例、分配金额要怎么对应？

写了一个代码，不知道符合不符合你的要求

z9bhd

铭拆分分配表.zip (37.73 KB, 下载次数: 37)

2021-3-27 22:22 上传

点击文件名下载附件

z9bhd

Sub 批量导出到模板()
Dim ar, br(), cr, i%, j%, wb1 As Workbook, wb2 As Workbook, wb As Workbook, a%
    Set wb1 = ThisWorkbook
    a = wb1.Sheets("04专业").Range("e2").End(xlDown).Row
    ar = wb1.Sheets("04专业").Range("b2:e" & a)
    Set wb2 = Workbooks.Open(wb1.Path & "\模板.xlsx")
    For i = 1 To UBound(ar)
        Set wb = Workbooks.Add
        wb1.Sheets.Copy before:=wb.Sheets(Sheets.Count)
        wb2.Sheets(1).UsedRange.Copy wb.Sheets(Sheets.Count).Range("a1")
        With wb.Sheets(Sheets.Count)
            .Name = ar(i, 2)
            For j = 1 To 4
                .Cells(4, j).Value = ar(i, j)
            Next j
        End With
        wb.SaveAs (wb1.Path & "\" & ar(i, 2) & ".xlsx")
        wb.Close
    Next i
    wb2.Close 0
    MsgBox "导出完毕！"
End Sub

紫寒100

z9bhd 发表于 2021-3-27 22:23

谢谢你，现在才上网，先试一下。

紫寒100

紫寒100 发表于 2021-3-28 13:45
谢谢你，现在才上网，先试一下。

效果很好，但是拆分出来的表，不想保留前面的几个，只是拆分出来的表另存为工作簿。帮我修改一下可以吗?谢谢啦。姓名列不填写，以后各部门手动填写。