|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub 填充word()
Application.ScreenUpdating = False
Dim i%, d, myPath$, wdApp, wdD
Set wdApp = CreateObject("word.application")
Set d = CreateObject("scripting.dictionary")
myPath = ThisWorkbook.Path & "\"
ar = Sheet1.[a1].CurrentRegion
For i = 2 To UBound(ar)
If Trim(ar(i, 11)) <> "" Then
d(Trim(ar(i, 11))) = ""
End If
Next i
For Each k In d.keys
n = 0
ReDim br(1 To UBound(ar), 1 To 8)
For i = 2 To UBound(ar)
If Trim(ar(i, 11)) = k Then
n = n + 1
br(n, 1) = n
br(n, 2) = ar(i, 4)
br(n, 3) = ar(i, 10)
br(n, 4) = ar(i, 5)
br(n, 5) = ar(i, 8)
br(n, 6) = ar(i, 9)
br(n, 7) = ar(i, 3)
br(n, 8) = ar(i, 11)
End If
Next i
FileCopy myPath & "上海.docx", myPath & "生成的文件\" & k & ".docx"
Set wdD = wdApp.Documents.Open(myPath & "生成的文件\" & k & ".docx")
wdApp.Visible = False
With wdD.Tables(1)
For i = 1 To n
For j = 1 To UBound(br, 2)
.Cell(i + 1, j).Range.Text = br(i, j)
Next j
Next i
End With
wdD.Save
wdD.Close
Next k
wdApp.Quit
Set wdD = Nothing
Set wdApp = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2020-6-18 11:30
楼主
