求助数据按模板拆分填充，类似邮件合并

riauxk

EH2003 发表于 2019-12-27 17:17
试试行不行？

谢谢，很好

EH2003

riauxk 发表于 2019-12-27 23:50
感谢，
能否直接利用工作簿里面的模板 Sheet1(模板)，再生成导出为PDF格式的

红色的部分为保存为PDF格式
.SaveAs ThisWorkbook.Path & "\文件\" & arr(i, 2) & ".xlsx"
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        ThisWorkbook.Path & "\文件\" & arr(i, 2) & ".pdf"
   End With

EH2003

riauxk 发表于 2019-12-28 01:30
谢谢，很好

红色部分为新增打印
End With
       ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
            IgnorePrintAreas:=False
whor.Close 1

riauxk

OK了，科目能否也是自动生成过去？

excel海

Option Explicit

Function myDate(sname$)
    Dim arr
    arr = Sheet2.UsedRange.Value
    Dim dic
    Set dic = CreateObject("scripting.dictionary")
    Dim n%, i%, r%, j%
    n = Sheet2.Cells(Rows.Count, 2).End(xlUp).Row
    For i = 4 To n
        dic(arr(i, 2)) = i
    Next
    r = dic(sname)
    ReDim brr(1 To 12, 1 To 4)
   
    For j = 1 To 4
        brr(1, j) = arr(r, j + 2)
        brr(2, j) = arr(r, j + 6)
        brr(3, j) = arr(r, j + 10)
        brr(4, j) = arr(r, j + 14)
        brr(5, j) = arr(r, j + 18)
        brr(6, j) = arr(r, j + 22)
        brr(7, j) = arr(r, j + 26)
        brr(8, j) = arr(r, j + 30)
        brr(9, j) = arr(r, j + 34)
        brr(10, j) = arr(r, j + 38)
        brr(11, j) = arr(r, j + 42)
        brr(12, j) = arr(r, j + 46)
    Next
    With Sheet1
        .Range("D4").Resize(12, 4) = brr
        .Cells(16, 3) = arr(r, 53)
        .Cells(17, 3) = arr(r, 54)
        .Cells(17, 5) = arr(r, 55)
        .Cells(17, 7) = arr(r, 56)
        .Cells(18, 3) = arr(r, 57)
        .Cells(18, 6) = arr(r, 58)
        .Cells(19, 2) = arr(r, 59)
        .Cells(21, 2) = arr(r, 60)
    End With
End Function
Sub savename()
    Dim i%, n%
    Dim arr
    n = Sheet2.Cells(Rows.Count, 2).End(xlUp).Row
    arr = Array("科目1", "科目2", "科目3", "科目4", "科目5", "科目6", "科目7", "科目8", "科目9", "科目10", "科目11", "科目12")
    Sheet1.Range("A4:A15") = Application.Transpose(arr)
    For i = 4 To n
        
        Sheet1.Cells(2, 6) = Sheet2.Cells(i, 2)
        myDate (Sheet1.Cells(2, 6).Value)
        Sheet1.Copy
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        ThisWorkbook.Path & "\" & Sheet1.Cells(2, 6).Value & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties _
        :=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
        ActiveWorkbook.Close False
    Next
End Sub

riauxk

EH2003 发表于 2019-12-27 17:04

谢谢，在您的帮助下，问题解决了，再次谢谢！

riauxk

excel海 发表于 2019-12-28 12:34
Option Explicit

Function myDate(sname$)

这方案更加实用，太赞了，
    arr = Array("???1", "???2", "???3", "???4", "???5", "???6", "???7", "???8", "???9", "???10", "???11", "???12")
科目只是代用词，怎么修改为直接引用表格位置的，数据表里面科目1、2、3会换成真实科目名。

excel海

riauxk 发表于 2019-12-29 14:21
这方案更加实用，太赞了，
    arr = Array("???1", "???2", "???3", "???4", "???5", "???6", "???7",  ...

简单点可以arr=array(sheet2.range("c1").value,sheet2.range("G1").value)这种模式,把它都引用进去

riauxk

excel海 发表于 2019-12-29 15:25
简单点可以arr=array(sheet2.range("c1").value,sheet2.range("G1").value)这种模式,把它都引用进去

谢谢，搞定

iwangyi

Sub C()
K = 3
N = [B65536].End(xlUp).Row
For i = 4 To N
Set mysheet = Sheets.Add
Sheets("模板").UsedRange.Copy mysheet.[a1]
mysheet.Name = Cells(i, 2)
With mysheet
.Cells(2, "f") = Cells(i, 2)
For j = 3 To 50 Step 4
K = K + 1
.Cells(K, 1) = Cells(2, j)
.Cells(K, "d").Resize(, 4) = Cells(i, j).Resize(, 4).Value
Next
.Cells(16, "c") = Cells(i, 53)
.Cells(17, "c") = Cells(i, 54)
.Cells(17, "e") = Cells(i, 55)
.Cells(17, "g") = Cells(i, 56)
.Cells(18, 1) = Cells(i, 57)
.Cells(18, "e") = Cells(i, 58)
.Cells(19, 2) = Cells(i, 59)
.Cells(21, 2) = Cells(i, 60)
End With
K = 3
Next
End Sub