利用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