VBA操控Word——批量生成询证函
本帖最后由 JLxiangwei 于 2014-11-29 11:26 编辑原帖地址：http://www.excelpx.com/thread-334836-1-1.html
表格格式：
最终效果：
代码供参考：
Sub Main()
Dim arr
Dim temp
Dim ArrXZ
Dim StrDate As String
arr = Sheet1.Range("a1").CurrentRegion
temp = GetRow(arr)
StrDate = Format(Date, "yyyymmdd")
For Irow = 1 To UBound(temp)
k = k + 1
ArrXZ = GetDataXZ(arr, temp(Irow, 1), temp(Irow, 2), StrDate & Format(k, "000"))
Call CreateWord(ArrXZ)
Next Irow
End Sub
Function GetRow(arr As Variant)
Dim Irow As Long
Dim Rarr()
For Irow = 2 To UBound(arr)
If Len(arr(Irow, 1)) > 0 Then
k = k + 1
ReDim Preserve Rarr(1 To 2, 1 To k)
Rarr(1, k) = Irow
End If
If arr(Irow, 2) = "小计" Then
Rarr(2, k) = Irow
End If
Next
GetRow = Application.WorksheetFunction.Transpose(Rarr)
End Function</P>
Function GetDataXZ(arr As Variant, x As Variant, y As Variant, StrDate As String)
Dim i As Long
Dim Rarr()
ReDim Preserve Rarr(1 To 2, 0 To 3)
k = 3
Rarr(1, 0) = StrDate
Rarr(1, 1) = arr(x, 1)
Rarr(1, 2) = Format(arr(x, 2), "yyyy年mm月dd日")
Rarr(1, 3) = Format(arr(y, 4), "￥#,##0.00")
For i = x To y - 1
k = k + 1
ReDim Preserve Rarr(1 To 2, 0 To k)
Rarr(1, k) = arr(i, 3)
Rarr(2, k) = arr(i, 4)
Next i
GetDataXZ = Rarr
End Function
Private Sub CreateWord(ArrXZ)
Dim FileNameO As String, FileNameN As String
Dim Irow As Long
Dim Icol As Long
Dim MyTable As Object
Dim MyLastRow As Object
Dim doc As Object
Application.ScreenUpdating = False
FileNameO = ThisWorkbook.Path & "\询证函模板.doc"
With CreateObject("Word.Application")
.Visible = False
FileNameN = ThisWorkbook.Path & "\询证函明细\" & ArrXZ(1, 1) & ".doc"
FileCopy FileNameO, FileNameN
Set doc = .Documents.Open(FileNameN, False)
For Irow = 0 To 3
.Selection.HomeKey Unit:=6
.Selection.Find.Execute ("【数据" & Irow & "】")
.Selection.Text = ArrXZ(1, Irow)
Next
Set MyTable = doc.Tables(1)
Set MyLastRow = MyTable.Rows.Last
If MyTable.Rows.Count <= UBound(ArrXZ, 2) - 4 Then
MyLastRow.Select
doc.Application.Selection.InsertRowsAbove UBound(ArrXZ, 2) - 4
End If
With MyTable
For Irow = 4 To UBound(ArrXZ, 2)
.Cell(Irow - 2, 1).Range.Text = Format(ArrXZ(1, 2), "yyyy年mm月dd日")
.Cell(Irow - 2, 2).Range.Text = Format(ArrXZ(1, Irow), "￥#,##0.00")
.Cell(Irow - 2, 3).Range.Text = Format(ArrXZ(2, Irow), "￥#,##0.00")
Next
End With
.Documents.Close True
.Quit
End With
Application.ScreenUpdating = True
End Sub
附件：
**** Hidden Message *****
{:1112:} 强大，学习。
这个好实用的！多谢向可可跟我们分享！{:11:}
感谢lz分享经验
正需要用
很好的分享，谢谢 这个需要学习...... 谢向可可跟我们分享 ooooooooooookkkkkkkkk