利用access VBA批量输出word文档 + Excel VBA

　　最近忙一个小项目，要求根据已有的历史与现状资料填写对照表格，总共有几十份，里面要求填的数据项也很琐碎，而且细节上可能会有小的变更与修改。

　　本人很懒，最讨厌就是繁琐的手工劳动与无休止的改来改去，刚巧有之前用数据采集软件生成的access数据库，焉能有不加以充分利用之理？于是俺就想办法咯。

　　既然是access与Word，那就用传说中的VBA咯，但木用过，就上Google猛搜……

　　终于找到了方法：利用VBA查询出需要的数据，然后通过word模板批量生成对照表格。

　　综合access软件网 竹笛和另外一个叫 Access+VBA套打Word+模板(三种方法) 的资料，经过数小时的调试，终于大功告成，啊哈哈哈，人民群众的智慧是无穷的哦~~~

　　过程介绍如下：

　　1、先把用做模板的word表格需插入数据项的位置加上书签(Bookmarks)。数据项多的话，书签最好用文字标记，并设置书签为显示状态，这样一目了然，不容易出错误。

　　2、在access新建一个窗体，拖一个Button上去，触发单击命令，开始在VB编辑器中敲代码……

　　3、查询各表得出需要的数据记录集 (Recordset)，利用循环语句读取每条记录，打开word模板，用数据项替换对应的word书签，然后保存。

　　--------完事大吉，批量输出啦，欧拉拉欧拉拉~~~

　　代码如下：

Code 

Option  Compare Database

Private   Sub  cmdExportAll_Click()

     Dim  rownum  As   Integer
     Dim  I, N  As   Integer

     ' 使用DAO操作打开明细记录集
     Dim  rs  As  DAO.Recordset
     Dim  sqlStr  As   String

     ' 单库多表查询，需事先将数据集中到一个mdb中
     ' sqlStr = "Select * from ckq b , yckq a where b.证号=a.证号"

     ' 跨库多表查询，连接多个mdb中数据表，不用倒腾数据，直接利用已有的mdb数据库，方便多了~~~
    sqlStr  =   " Select * from [;database= "   &  CurrentProject.Path  &   " \ckq.mdb].ckq b , [;database= "   &  CurrentProject.Path  &   " \yckq.mdb].yckq a where b.证号=a.证号 "
     Set  rs  =  CurrentDb.OpenRecordset(sqlStr)

     ' 如果没有记录 , 不执行下面程序
     If  rs.EOF  Then   Exit   Sub

     ' 为了能得到记录总数量,DAO记录集要先把记录集位置移到最后,否则得不到RECORDCOUNT
    rs.MoveLast
    rs.MoveFirst

    rownum  =  rs.RecordCount

     ' 多条数据的处理,使用循环
     For  I  =   1   To  rownum
  
         ' 创建Word对象
         Set  doc  =   CreateObject ( " word.application " )
        doc.Visible  =   True
         ' 打开Word文件
         Dim  mydoc  As   Object
         Set  mydoc  =  doc.Documents.Add(CurrentProject.Path  &   " \表格模板.doc " )  ' 使用定义好的模板创建新文件

         ' mydoc.Bookmarks("template_content_en").Range.Text = (rs!测试字段)
         ' (rs.Fiel(ds(0).Name) '(rs.Fields(0).Value)

         ' 最后面加上 & "" 避免了当字段为NULL时程序出错中断,省却不少代码行与麻烦,真TMD太有用了
        mydoc.Bookmarks( " 证号 " ).Range.Text  =  rs.Fields( " b.证号 " ).Value  &   ""
        mydoc.Bookmarks( " 项目名称 " ).Range.Text  =  rs.Fields( " b.项目名称 " ).Value  &   ""
        mydoc.Bookmarks( " a传真 " ).Range.Text  =  rs.Fields( " a.传真 " ).Value  &   ""
        mydoc.Bookmarks( " b传真 " ).Range.Text  =  rs.Fields( " b.传真 " ).Value  &   ""
        mydoc.Bookmarks( " a电话 " ).Range.Text  =  rs.Fields( " a.电话 " ).Value  &   ""
        mydoc.Bookmarks( " b电话 " ).Range.Text  =  rs.Fields( " b.电话 " ).Value  &   ""
        mydoc.Bookmarks( " a地址 " ).Range.Text  =  rs.Fields( " a.地址 " ).Value  &   ""
        mydoc.Bookmarks( " b地址 " ).Range.Text  =  rs.Fields( " b.地址 " ).Value  &   ""

         ' 以下省略N项
         ' .........
         ' .........

         Select   Case  rs.Fields( " a.项目类型 " ).Value  &   ""
             Case   " 1 "
                mydoc.Bookmarks( " a1 " ).Range.Text  =   " √ "
                mydoc.Bookmarks( " a2 " ).Range.Text  =   ""
             Case   " 2 "
                mydoc.Bookmarks( " a1 " ).Range.Text  =   ""
                mydoc.Bookmarks( " a2 " ).Range.Text  =   " √ "
             Case   Else
                mydoc.Bookmarks( " a1 " ).Range.Text  =   ""
                mydoc.Bookmarks( " a2 " ).Range.Text  =   ""
         End   Select

         ' 以下为坐标数字串，XY坐标分开存储，X11位，Y12位，读取时根据位数截取

         ' mid("1234",2,2)
         ' mid(string,start,len)
         ' Mid("1234",   insrt("1234","23"),   len("23"))
         Dim  XA, YA, XB, YB  As   String
        XA  =  rs.Fields( " a.经度坐标 " ).Value  &   ""
        YA  =  rs.Fields( " a.纬度坐标 " ).Value  &   ""
        XB  =  rs.Fields( " b.经度坐标 " ).Value  &   ""
        YB  =  rs.Fields( " b.纬度坐标 " ).Value  &   ""
         ' Dim XYnum As Integer
         ' XYnum = Len(XB) / 11
         For  N  =   1   To   22
        mydoc.Bookmarks( " XA "   &  N).Range.Text  =   Mid (XA, N  *   11   +   1 ,  11 )  &   ""
        mydoc.Bookmarks( " YA "   &  N).Range.Text  =   Mid (YA, N  *   12   +   1 ,  12 )  &   ""
        mydoc.Bookmarks( " XB "   &  N).Range.Text  =   Mid (XB, N  *   11   +   1 ,  11 )  &   ""
        mydoc.Bookmarks( " YB "   &  N).Range.Text  =   Mid (YB, N  *   12   +   1 ,  12 )  &   ""
         Next

         ' If XYnum < 14 Then
         ' For N = XYnum + 1 To 14
         ' mydoc.Bookmarks("XB" & N).Range.Text = ""
         ' mydoc.Bookmarks("YB" & N).Range.Text = ""
         ' Next
         ' 'Else
         ' End If

         ' 保存word文档
        mydoc.SaveAs CurrentProject.Path  &   " \ "   &  rs.Fields( " a.项目名称 " ).Value  &   " .doc "

         ' 释放对象变量
         Set  doc  =   Nothing
        rs.MoveNext

     Next
    rs.Close

End Sub

  

　　2010年1月12日，试验了一下Excel VBA下的批量输出，代码如下： 

Code 

Private   Sub  CommandButton1_Click()
     Dim  I  As   Integer
     For  I  =   1   To   5     ' rownum  '多条数据的处理,使用循环
         ' 创建Word对象
         Set  doc  =   CreateObject ( " word.application " )
        doc.Visible  =   True
         ' 打开Word文件
         Dim  mydoc  As   Object
         Set  mydoc  =  doc.Documents.Add(ActiveWorkbook.Path  &   " \说明模板.doc " )  ' 使用定义好的模板创建新文件，access中取当前路径为CurrentProject.Path
         ' 开始替换书签
        mydoc.Bookmarks( " 许可证号 " ).Range.Text  =  Cells(I  +   1 ,  1 ).Value  &   ""
        mydoc.Bookmarks( " 法人代表 " ).Range.Text  =  Cells(I  +   1 ,  2 ).Value  &   ""
        mydoc.Bookmarks( " 地址 " ).Range.Text  =  Cells(I  +   1 ,  3 ).Value  &   ""
        mydoc.Bookmarks( " 名称 " ).Range.Text  =  Cells(I  +   1 ,  4 ).Value  &   ""
                
        mydoc.Bookmarks( " 日期 " ).Range.Text  =  Format(Cells(I  +   1 ,  23 ).Value  &   "" ,  " yyyy年m月d日 " )
        
         Dim  N & , Dr, Ddr$
         Dim  pathFileSaved  As   String
        
         ' 指定报表生成路径引用，正式路径
         ' pathFileSaved = CurrentProject.Path & "\CKQ\410000\" & Cells(I + 1, 1).Value & "\属性数据\说明"
        
         ' 以下为测试路径
        pathFileSaved  =  ActiveWorkbook.Path  &   " \测试输出 "
         ' 文件目录不存在的情况下,建立文件目录,文件目录按 pathFileSaved
         On   Error   Resume   Next
        Dr  =   Split (pathFileSaved,  " \ " )
        Ddr  =  Dr( 0 )
         For  N  =   1   To   UBound (Dr)
            Ddr  =  Ddr  &   " \ "   &  Dr(N)
            MkDir Ddr
         Next
        Err.Clear
         On   Error   GoTo   0
        
         ' mydoc.SaveAs pathFileSaved & "\DQK" & Cells(I + 1, 1).Value & ".doc" '正式名称
        mydoc.SaveAs pathFileSaved  &   " \ "   &  Cells(I  +   1 ,  4 ).Value  &   " DQK "   &  Cells(I  +   1 ,  1 ).Value  &   " .doc "   ' 测试名称
         ' 释放对象变量
         Set  doc  =   Nothing
     Next
End Sub

  

转载于:https://www.cnblogs.com/nuist/archive/2009/09/03/1559860.html