|
|
Sub 按模板生成文档()
Application.ScreenUpdating = False
Dim i%, arr, myPath$, wdApp, wdD
Dim oFso
Set oFso = CreateObject("Scripting.FileSystemObject")
Dim d As Object
Set d = CreateObject("scripting.dictionary")
myPath = ThisWorkbook.Path & "\"
Set wdApp = CreateObject("word.application")
wdApp.Visible = True
arr = Sheets("sheet1").Range("A1:h" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = 2 To UBound(arr)
If Trim(arr(i, 1)) <> "" Then
zf = Trim(arr(i, 1))
d(zf) = ""
End If
Next i
For Each k In d.keys
n = 0
ReDim br(1 To UBound(arr), 1 To 8)
For i = 2 To UBound(arr)
If Trim(arr(i, 1)) = k Then
n = n + 1
For j = 1 To 8
br(n, j) = arr(i, j)
Next j
End If
Next i
FileCopy myPath & "模板.docx", myPath & "生成的文件\" & k & ".docx"
Set wdD = wdApp.Documents.Open(myPath & "生成的文件\" & k & ".docx")
xh = 7
For i = 1 To n
With wdD.Tables(1)
.cell(2, 6).Range.Text = k
.cell(3, 2).Range.Text = br(i, 2)
.cell(4, 6).Range.Text = br(i, 8)
.cell(5, 6).Range.Text = br(i, 7)
xh = xh + 1
.cell(xh, 2).Range.Text = br(i, 3)
.cell(xh, 3).Range.Text = br(i, 4)
.cell(xh, 4).Range.Text = br(i, 5)
.cell(xh, 5).Range.Text = br(i, 6)
.cell(xh, 2).Range.Text = br(i, 3)
End With
Next i
wdD.Save
wdD.Close True
Next k
wdApp.Quit
Set wdD = Nothing
Set wdApp = Nothing
Application.ScreenUpdating = False
MsgBox "ok!"
End Sub
|
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-7-4 16:25
楼主
