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

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