VBA操控Word——批量生成询证函

JLxiangwei

原帖地址：http://www.excelpx.com/thread-334836-1-1.html

表格格式：

最终效果：



代码供参考：

1. 
   
2. Sub Main()
   
3.     Dim arr
   
4.     Dim temp
   
5.     Dim ArrXZ
   
6.     Dim StrDate As String
   
7.     arr = Sheet1.Range("a1").CurrentRegion
   
8.     temp = GetRow(arr)
   
9.     StrDate = Format(Date, "yyyymmdd")
   
10.     For Irow = 1 To UBound(temp)
    
11.             k = k + 1
    
12.             ArrXZ = GetDataXZ(arr, temp(Irow, 1), temp(Irow, 2), StrDate & Format(k, "000"))
    
13.             Call CreateWord(ArrXZ)
    
14.     Next Irow
    
15. End Sub
    
16. Function GetRow(arr As Variant)
    
17.     Dim Irow As Long
    
18.     Dim Rarr()
    
19.     For Irow = 2 To UBound(arr)
    
20.         If Len(arr(Irow, 1)) > 0 Then
    
21.             k = k + 1
    
22.             ReDim Preserve Rarr(1 To 2, 1 To k)
    
23.             Rarr(1, k) = Irow
    
24.         End If
    
25.         If arr(Irow, 2) = "小计" Then
    
26.             Rarr(2, k) = Irow
    
27.         End If
    
28.     Next
    
29.     GetRow = Application.WorksheetFunction.Transpose(Rarr)
    
30. End Function</P>
    
31. Function GetDataXZ(arr As Variant, x As Variant, y As Variant, StrDate As String)
    
32.     Dim i As Long
    
33.     Dim Rarr()
    
34.     ReDim Preserve Rarr(1 To 2, 0 To 3)
    
35.     k = 3
    
36.     Rarr(1, 0) = StrDate
    
37.     Rarr(1, 1) = arr(x, 1)
    
38.     Rarr(1, 2) = Format(arr(x, 2), "yyyy年mm月dd日")
    
39.     Rarr(1, 3) = Format(arr(y, 4), "￥#,##0.00")
    
40.     For i = x To y - 1
    
41.         k = k + 1
    
42.         ReDim Preserve Rarr(1 To 2, 0 To k)
    
43.         Rarr(1, k) = arr(i, 3)
    
44.         Rarr(2, k) = arr(i, 4)
    
45.     Next i
    
46.     GetDataXZ = Rarr
    
47. End Function
    
48. Private Sub CreateWord(ArrXZ)
    
49.     Dim FileNameO As String, FileNameN As String
    
50.     Dim Irow As Long
    
51.     Dim Icol As Long
    
52.     Dim MyTable As Object
    
53.     Dim MyLastRow As Object
    
54.     Dim doc As Object
    
55.     Application.ScreenUpdating = False
    
56.     FileNameO = ThisWorkbook.Path & "\询证函模板.doc"
    
57.     With CreateObject("Word.Application")
    
58.         .Visible = False
    
59.         FileNameN = ThisWorkbook.Path & "\询证函明细" & ArrXZ(1, 1) & ".doc"
    
60.         FileCopy FileNameO, FileNameN
    
61.         Set doc = .Documents.Open(FileNameN, False)
    
62.         For Irow = 0 To 3
    
63.             .Selection.HomeKey Unit:=6
    
64.             .Selection.Find.Execute ("【数据" & Irow & "】")
    
65.             .Selection.Text = ArrXZ(1, Irow)
    
66.         Next
    
67.         Set MyTable = doc.Tables(1)
    
68.         Set MyLastRow = MyTable.Rows.Last
    
69.         If MyTable.Rows.Count <= UBound(ArrXZ, 2) - 4 Then
    
70.             MyLastRow.Select
    
71.             doc.Application.Selection.InsertRowsAbove UBound(ArrXZ, 2) - 4
    
72.         End If
    
73.         With MyTable
    
74.             For Irow = 4 To UBound(ArrXZ, 2)
    
75.                 .Cell(Irow - 2, 1).Range.Text = Format(ArrXZ(1, 2), "yyyy年mm月dd日")
    
76.                 .Cell(Irow - 2, 2).Range.Text = Format(ArrXZ(1, Irow), "￥#,##0.00")
    
77.                 .Cell(Irow - 2, 3).Range.Text = Format(ArrXZ(2, Irow), "￥#,##0.00")
    
78.             Next
    
79.         End With
    
80.         .Documents.Close True
    
81.         .Quit
    
82.     End With
    
83.     Application.ScreenUpdating = True
    
84. End Sub
    

复制代码

附件：

游客，如果您要查看本帖隐藏内容请回复

刘苏

{:1112:}

qwqw8899

强大，学习。

xlz2124

这个好实用的！多谢向可可跟我们分享！{:11:}

foddkidman

感谢lz分享经验

yyfdh

正需要用

gblhp1979

很好的分享，谢谢

byhdch

这个需要学习......

ad4561

谢向可可跟我们分享

ycbwg

ooooooooooookkkkkkkkk