【Excel Word VBA】农村集体产权制度改革“股权证”打印文件制作

去年五一，用ExcelDNA+C#的方式写了一个输出河北股权证的插件工具。

前段时间又使用Excel vba的方式写了几个输出股权证的工具。

前面一直使用Excel作为输出文件，对于左右两页格子不等高的证书，使用Excel输出便出现了不能解决的难题——在Excel中不能随意定义行高，通过合并单元格的形式也难以实现左右两页合为一页输出，而分两页输出会增加打印时的送纸次数，影响效率。

那么，使用Word输出是不是一个更好的选择？经测试，效果是理想的。通过分栏的形式，在一页的左右两栏分别插入表格，对表格的行高、列宽、地址进行定义，提取Excel数据填写Word模板，另存Word文件。

实现代码如下：

注意 

①代码宿主为Excel，因为博主已经做了现成的Ribbon，懒得换为Word；

②为方便操作者使用，代码中Word对象与FSO对象的创建采用了“后期绑定”；

③IsFileExist函数用于主过程中调用以判断所需的文件是否存在。

Sub Generate(control As IRibbonControl)
    Dim wordApp As Object
    Dim sourceBook, institutionBook As Workbook
    Dim templateDoc As Object
    Dim wsSource, wsInstitution As Worksheet
    Dim mainFolder, institutionCode, desFolderPath, newDocName As String
    Dim rowCount, indexOfTable, indexOfNo3 As Integer
    
    Set wordApp = CreateObject("Word.Application")
    wordApp.ScreenUpdating = False
    wordApp.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    mainFolder = ThisWorkbook.path
'   get data source book
    If IsFileExists(mainFolder + "" + "成员信息.xlsx") Then
        Workbooks.Open Filename:=mainFolder + "" + "成员信息.xlsx"
        Set sourceBook = ActiveWorkbook
    Else
        MsgBox "成员信息.xlsx 在当前路径下不存在！"
        Exit Sub
    End If
'   get institution infos book
    If IsFileExists(mainFolder + "" + "机构信息.xls") Then
        Workbooks.Open Filename:=mainFolder + "" + "机构信息.xls"
        Set institutionBook = ActiveWorkbook
        Set wsInstitution = institutionBook.Worksheets(1)
    Else
        MsgBox "机构信息.xls 在当前路径下不存在！"
        sourceBook.Close
        Exit Sub
    End If
'   get template word document
    If IsFileExists(mainFolder + "" + "证书模板.docx") Then
        wordApp.Documents.Open Filename:=mainFolder + "" + "证书模板.docx"
        Set templateDoc = wordApp.ActiveDocument
    Else
        MsgBox "证书模板.docx"
        sourceBook.Close
        institutionBook.Close
        Exit Sub
    End If

    For Each wsSource In sourceBook.Worksheets
        indexOfInstInfoRow = wsInstitution.Cells.Find(what:=wsSource.Range("A2").Text, After:=[b1], searchorder:=XlSearchOrder.xlByColumns, _
        SearchDirection:=XlSearchDirection.xlPrevious).Row
        '社会信用代码
        templateDoc.Tables(1).Cell(1, 2).Range = wsInstitution.Cells(indexOfInstInfoRow, 1).Value
        '组织名称
        templateDoc.Tables(1).Cell(2, 2).Range = wsInstitution.Cells(indexOfInstInfoRow, 2).Value
        '法定代表人
        templateDoc.Tables(1).Cell(4, 2).Range = wsInstitution.Cells(indexOfInstInfoRow, 3).Value
        '机构区划代码，用于生成股权证号
        institutionCode = wsInstitution.Cells(indexOfInstInfoRow, 4).Text
        'create folder named as each worksheet's name.
        desFolderPath = mainFolder + "" + wsSource.Name
        If Dir(desFolderPath, vbDirectory) = vbNullString Then
           MkDir desFolderPath
        End If
        '
        rowCount = wsSource.Range("e65536").End(xlUp).Row
        For i = rowCount To 4 Step -1
            k = k + 1
            If wsSource.Range("A" & i).Text <> "" Then
                templateDoc.Tables(1).Cell(6, 2).Range = "GQZ" + institutionCode + Format(wsSource.Range("A" & i), "0000")
                'clear tables'comtents
                For Each oCell In templateDoc.Tables(2).Range.Cells
                    oCell.Range.Text = ""
                Next oCell
                For r = 1 To 13
                    For c = 1 To 4
                        templateDoc.Tables(3).Cell(r, c).Range.Text = ""
                    Next c
                Next r
                
                indexOfTable = 1
                indexOfNo3 = 1
                For j = i To i + k - 1 Step 1
                    templateDoc.Tables(2).Cell(indexOfTable, 1).Range.Text = wsSource.Cells(j, 4).Value
                    templateDoc.Tables(2).Cell(indexOfTable, 2).Range.Text = wsSource.Cells(j, 6).Value
                    templateDoc.Tables(2).Cell(indexOfTable, 3).Range.Text = wsSource.Cells(j, 8).Value
                    templateDoc.Tables(2).Cell(indexOfTable, 4).Range.Text = wsSource.Cells(j, 9).Value
                    templateDoc.Tables(3).Cell(indexOfTable, 2).Range.Text = wsSource.Cells(j, 4).Value
                    templateDoc.Tables(3).Cell(indexOfTable, 3).Range.Text = 10
                    indexOfTable = indexOfTable + 1
                    If indexOfTable = 13 Then
                        Exit For
                    End If
                Next j
                templateDoc.Tables(3).Cell(14, 3).Range.Text = 10 * k
                k = 0
                'save as a new doc
                newDocName = desFolderPath & "" & wsSource.Range("A" & i).Text & wsSource.Range("B" & i).Text & "_股权证书.docx"
                templateDoc.SaveAs Filename:=newDocName, FileFormat:=wdFormatXMLDocument
                
            End If
        Next i
    Next
    sourceBook.Close
    institutionBook.Close
    templateDoc.Close
    wordApp.Quit
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "输出完成！"
End Sub

Function IsFileExists(ByVal strFileName As String) As Boolean
    Dim objFileSystem As Object
    Set objFileSystem = CreateObject("Scripting.FileSystemObject")
    If objFileSystem.fileExists(strFileName) = True Then
        IsFileExists = True
    Else
        IsFileExists = False
    End If
End Function