excel数据与word模板导入

182197315

Sub 根据模板生成文档()
Dim i%, j%, k%, x%, y%, ss$, s$
Dim arr, temp, krr, trr, tm, t, rArr, tArr
Dim myPath$, OmyFile$, Nmyfile$, myPic$
Dim wdApp, d, wdD
Set wdApp = CreateObject("Word.Application")
Set d = CreateObject("scripting.dictionary")
myPath = ThisWorkbook.Path & "\"
arr = Range("A1:W" & Cells(Rows.Count, 4).End(xlUp).Row)

For i = 2 To UBound(arr)
    If arr(i, 1) <> "" Then
        If ss <> "" Then ss = ss & "-"
        ss = ss & i
    End If
Next
rArr = Split(ss, "-")
ReDim tArr(0 To UBound(rArr))
For j = 0 To UBound(rArr) - 1
    tArr(j) = rArr(j + 1) - 1
Next
tArr(UBound(tArr)) = UBound(arr)

For k = 0 To UBound(rArr)
    s = arr(rArr(k), 1) & "-" & arr(rArr(k), 2) & "-" & arr(rArr(k), 3)
    temp = Range("D" & rArr(k) & ":W" & tArr(k)).Value
    d(s) = temp
Next

krr = d.Keys
OmyFile = "成绩报告单模板.docx"
For j = 0 To UBound(krr)
    t = Split(krr(j), "-")
    Nmyfile = t(1) & "_" & t(0) & "学生毕业个人成绩明细清单" & ".docx"
    FileCopy myPath & OmyFile, myPath & "生成学生成绩单\" & Nmyfile
    tm = d(krr(j))
    Set wdD = wdApp.Documents.Open(myPath & "生成学生成绩单\" & Nmyfile)
    With wdD.Tables(1)
        .Cell(2, 2).Range.Text = t(2)
        .Cell(2, 4).Range.Text = t(1)
        .Cell(3, 4).Range.Text = t(0)
        myPic = myPath & "学生照片\" & t(0) & ".jpg"
        If Dir(myPic) <> "" Then
            With .Cell(5, 1).Range
                .InlineShapes.AddPicture Filename:=myPic, _
                LinkToFile:=False, SaveWithDocument:=True
               .InlineShapes(1).Height = 250
               .InlineShapes(1).Width = 550
            End With
        End If
        If UBound(tm) > 1 Then
            .Cell(8, 20).Select
            wdApp.Selection.InsertRowsBelow UBound(tm) - 1
        End If
        For x = 1 To UBound(tm)
            .Cell(7 + x, 1).Range.Text = x
            .Cell(7 + x, 2).Range.Text = tm(x, 1)
            .Cell(7 + x, 3).Range.Text = tm(x, 2)
            For y = 4 To 18
                .Cell(7 + x, y).Range.Text = tm(x, y + 2)
            Next
        Next
    End With
    wdD.Save
    wdD.Close
Next
Set wdD = Nothing
wdApp.Quit
Set d = Nothing
End Sub

182197315

这是附件，可以实现目的。