Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

数据透视表40+个常用小技巧,让你一次学会!
查看: 13790|回复: 59

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

  [复制链接]
发表于 2014-11-29 11:25 | 显示全部楼层 |阅读模式
本帖最后由 JLxiangwei 于 2014-11-29 11:26 编辑

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

表格格式:

最终效果:



代码供参考:

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

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


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
发表于 2014-11-29 11:28 | 显示全部楼层
回复

使用道具 举报

发表于 2014-11-30 21:06 | 显示全部楼层
回复

使用道具 举报

发表于 2014-12-3 16:36 | 显示全部楼层
这个好实用的!多谢向可可跟我们分享!{:11:}
回复

使用道具 举报

发表于 2014-12-3 22:41 | 显示全部楼层
感谢lz分享经验
回复

使用道具 举报

发表于 2015-1-16 18:26 | 显示全部楼层
正需要用
回复

使用道具 举报

发表于 2015-1-16 20:02 | 显示全部楼层
很好的分享,谢谢
回复

使用道具 举报

发表于 2015-1-16 22:26 | 显示全部楼层
这个需要学习......
回复

使用道具 举报

发表于 2015-1-17 11:12 | 显示全部楼层
谢向可可跟我们分享
回复

使用道具 举报

发表于 2015-3-11 14:57 | 显示全部楼层
ooooooooooookkkkkkkkk
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2023-2-5 18:08 , Processed in 1.012251 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表