VBA Excel填写表格、自动生成报告关键代码

Sub NDataCheck()       '获取E列的数据，并校验    end_row = Range("E65536").End(xlUp).Row 'E列数据最后行号    For i = 2 To end_row        'If Cells(i, "E").Interior.ColorIndex 43 Then        '    Exit For        'End If               If Cells(i, "E") = "" Then            MsgBox Cells(i, "A") & "测试值为空"        ElseIf IsNumeric(Cells(i, "E")) Then            If Cells(i, "C")                Cells(i, "F") ="合格"            Else                Cells(i, "F") ="不合格"            End If        Else            MsgBox Cells(1, "E") & "测试值非数值"        End If    Next End Sub Sub DataStore()       'Word后期绑定    Dim wdapp As Object    Dim wdDoc As Object    Dim wdTable As Object       Set wdapp = CreateObject("word.application")   '打开一个word运用环境    wdapp.Visible = False   '允许word文件可见     Set wdDoc = wdapp.Documents.Open("D:\word\txt2.docx",Visible:=False)    Set wdTable = wdDoc.Tables(1)   '选中第一个表格       With wdTable        For i = 2 To 6            .Cell(i, 5).Range.Text = Cells(i, "E")        Next    End With       'wdapp.Saved = True '将保存文档的Saved属性设置为True，这样后台运行的Word在保存文档时就不会弹出是否保存的对话框了，达到悄无声息的效果    wdDoc.Close True    'wdapp.ActiveDocument.SaveAs ("D:\word\导出数据.docx")'调用saveas命令保存文档，根据实际，指定文档的保存路径和名称    wdapp.Application.Quit '退出并关闭程序文档    Set wdapp = Nothing '释放对象 End Sub Sub DataStore1()       'Word后期绑定    Dim wdapp As Object    Dim wdDoc As Object    Dim wdTable As Object    Setwdapp = CreateObject("word.application")   '打开一个word运用环境    wdapp.Visible = True   '允许word文件可见        'Set wd = wdapp.Documents.Add    '新建一个word文档    'Set tb = wd.Tables.Add(wd.Range(0, 0), 3, 6)   '在文档开始处加入一个3行6列的表格！！      Dim strArray() As Variant, xlSheet As Worksheet, myDialog As FileDialog,oSel As Variant    Dim myArray(16) As String, r As Integer, i As Integer    On Error Resume Next    r= ActiveSheet.[a65536].End(xlUp).Row    '定义一个一维数组，给EXCEL数据表表头赋值    strArray = Array("姓名", "性别", "民族", "出生年月", "工作时间", "政治面貌及加入党派时间", "所在单位（部门）", "所在学科", "最高学位、取得时间及毕业学校", "最高学历、取得时间及毕业学校", "现任专业技术职务及取得时间", "现专业技术职务任职年限", "现从事专业及年限", "兼职研究生导师", "取得时间及受聘学校", "党政职务", "任职年限", "现聘岗位等级", "拟申报岗位类别", "拟申报岗位等级", "教师岗位类型", "拟聘方式", "符合条件明细（符合第X、X、X、…、项）", "备 注")    Set myDialog = Application.FileDialog(msoFileDialogFilePicker)    With myDialog        .Filters.Clear    '清除所有文件筛选器中的项目        .Filters.Add "所有 WORD 文件", "*.doc,*.docx", 1    '增加筛选器的项目为所有WORD文件        .AllowMultiSelect = True    '允许多项选择        If .Show = -1 Then    '确定        Application.ScreenUpdating = False            For Each oSel In .SelectedItems    '在所有选取word文档中循环                Set wdDoc =wdapp.Documents.Open(Filename:=oSel, Visible:=False)                For i = 1 TowdDoc.Tables.Count '在一个word文档的所有表格中循环                    Set wdTable =wdDoc.Tables(i)                    With wdTable '将word文档中指定的单元格内容赋值给数组                       myArray(0) =Replace(.Cell(1, 2).Range.Text, Chr(13) & Chr(7), "")                       myArray(1) = Replace(.Cell(1,4).Range.Text, Chr(13) & Chr(7), "")                       myArray(2) =Replace(.Cell(1, 6).Range.Text, Chr(13) & Chr(7), "")                       myArray(3) =Replace(.Cell(1, 8).Range.Text, Chr(13) & Chr(7), "")                       myArray(4) =Replace(.Cell(2, 2).Range.Text, Chr(13) & Chr(7), "")                       myArray(5) =Replace(.Cell(2, 4).Range.Text, Chr(13) & Chr(7), "")                       myArray(6) =Replace(.Cell(2, 6).Range.Text, Chr(13) & Chr(7), "")                       myArray(7) =Replace(.Cell(3, 2).Range.Text, Chr(13) & Chr(7), "")                       myArray(8) =Replace(.Cell(3, 4).Range.Text, Chr(13) & Chr(7), "")                       myArray(9) =Replace(.Cell(3, 6).Range.Text, Chr(13) & Chr(7), "")                       myArray(10) =Replace(.Cell(4, 2).Range.Text, Chr(13) & Chr(7), "")                       myArray(11) =Replace(.Cell(4, 4).Range.Text, Chr(13) & Chr(7), "")                       myArray(12) =Replace(.Cell(4, 6).Range.Text, Chr(13) & Chr(7), "")                       myArray(13) =Replace(.Cell(5, 2).Range.Text, Chr(13) & Chr(7), "")                       myArray(14) = Replace(.Cell(5,4).Range.Text, Chr(13) & Chr(7), "")                       myArray(15) =Replace(.Cell(6, 2).Range.Text, Chr(13) & Chr(7), "")                    End With                    r = r + 1 '变换行号                    Sheets(1).Range(Cells(r,1), Cells(r, 8)).Value = myArray '为单元格区域赋值                Next '完成一个文件的赋值                wdDoc.Close False            Next          With Sheets(1)              .Rows(1).Insert '插入表头行              .[A1:H1].Value = strArray              .UsedRange.Columns.AutoFit          End With        End If    End With    wdapp.Quit    Set wdapp = Nothing    Application.ScreenUpdating = True '恢复屏幕更新 End Sub Public gReportName As StringgReportRefName = ActiveWorkbook.Path &"\txt2.docx" Sub DataStoreToExistedWord()     'Word后期绑定    Dim wdapp As Object    Dim wdDoc As Object    Dim wdTable As Object       Set wdapp = CreateObject("word.application")   '打开一个word运用环境    wdapp.Visible = False   '允许word文件可见     Set wdDoc = wdapp.Documents.Open("D:\word\txt2.docx",Visible:=False)    Set wdTable = wdDoc.Tables(1)   '选中第一个表格       With wdTable        For i = 2 To 6            .Cell(i, 5).Range.Text = Cells(i, "E")        Next    End With       'wdapp.Saved = True '将保存文档的Saved属性设置为True，这样后台运行的Word在保存文档时就不会弹出是否保存的对话框了，达到悄无声息的效果       wdapp.ActiveDocument.SaveAs "D:\word\导出数据.docx"'调用saveas命令保存文档，根据实际，指定文档的保存路径和名称    wdDoc.Close False    wdapp.Application.Quit '退出并关闭程序文档    Set wdapp = Nothing '释放对象 End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''DataStoreToNewWordHighLev为最顶层函数，是每个表单《保存数据到新建文档》事件的响应函数 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Sub DataStoreToNewWord()    '根据当前表单的名字获取以下内容：    '1 在word中对应的表格编号    '2 测试数据的列号    '之后，将1、2作为参数，调用宏DataStoreToNewWordBasedEndEnd Sub Sub DataStoreToNewWordBased(tblNum AsInteger, wrColNum As Integer)    'Word后期绑定    Dim wdapp As Object    Dim wdDoc As Object    Dim wdTable As Object       Dim strCurTime As String       strCurTime = Year(Now) & Month(Now) & Day(Now) & Hour(Now)& Minute(Now)    '获取当前时间，命名新建Word文档       Set wdapp = CreateObject("word.application")   '打开一个word运用环境    wdapp.Visible = False   '设置word不可见     Set wdDoc = wdapp.Documents.Open(Filename:=gReportRefName,Visible:=False, ReadOnly:=True)    Set wdTable = wdDoc.Tables(tblNum)   '选中第一个表格       rStart = 2  '填写起始行号    rEnd = ActiveSheet.[65536,wrColNum].End(xlUp).Row   '填写截止行号    With wdTable        For i = rStart To rEnd            .Cell(i, wrColNum).Range.Text = Cells(i, wrColNum)        Next    End With           wdDoc.SaveAs2 Filename:=ActiveWorkbook.Path & "\测试报告" & strCurTime & ".docx"  '调用saveas命令保存文档，根据实际，指定文档的保存路径和名称    wdDoc.Close False   '关闭文件不保存    wdapp.Application.Quit  '退出并关闭程序文档    Set wdapp = Nothing '释放对象    Set wdDoc = Nothing '释放对象    Set wdTable = Nothing   '释放对象   End Sub