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

 '''''''''''''''''''''''''''' 通用数据校验宏'''''''''''''''''''''''''''Dim gTestVal(100) As StringSub TblCheckBased(TblNum As Integer)    Dim CurTable As Table    '行列号    Dim rowNum_start As Integer    Dim rowNum_end As Integer       Dim colNum_testVal As Integer   'testVal 所在列号    Dim colNum_isOK As Integer  '是否合格所在列号       Dim colNum_testValMin As Integer    'testVal有效最小值 所在列号    Dim colNum_testValMax As Integer    'testVal有效最大值 所在列号       '浮点数    Dim testVal As Double    Dim testValMin As Double    Dim testValMax As Double       Dim strTmp As String     Dim lProt As Long: Const Pwd As String = "123"       '待校验表格    Set CurTable = ThisDocument.Tables(TblNum)    With CurTable           '赋值起始、终止行号        rowNum_start = 2        rowNum_end = .Rows.Count               '赋值使用的列号        colNum_isOK = .Columns.Count        '是否合格：倒数第一列        colNum_testVal = .Columns.Count - 1  'testVal：倒数第二列        colNum_testValMax = .Columns.Count - 2  'testVal有效最大值：倒数第三列        colNum_testValMin = .Columns.Count - 3  'testVal有效最小值：倒数第四列                For i = rowNum_start To rowNum_end            gTestVal(i) =Replace(.Cell(i, colNum_testVal).Range.Text, Chr(13) & Chr(7),"")            If gTestVal(i) = "" Then                MsgBox "测试值为空" '.Cell(i, 1).Range.Text & "测试值为空"            ElseIf IsNumeric(gTestVal(i)) Then                testVal = Val(gTestVal(i))                testValMin =Val(Replace(.Cell(i, colNum_testValMin).Range.Text, Chr(13) & Chr(7),""))                testValMax =Val(Replace(.Cell(i, colNum_testValMax).Range.Text, Chr(13) & Chr(7),""))                               IfThisDocument.ProtectionType wdNoProtection Then                    lProt =ThisDocument.ProtectionType                    ThisDocument.UnprotectPassword:=Pwd                End If                'insert your code for contentcontrol additions here                If testValMin                    .Cell(i,colNum_isOK).Range.Text = "合格"                Else                    .Cell(i,colNum_isOK).Range.Text = "不合格"                End If                                              If lProtwdNoProtection Then                    ThisDocument.ProtectType:=lProt, NoReset:=True, Password:=Pwd                End If                                         Else                MsgBox "测试值非数值"   '.Cell(i,1).Range.Text & "测试值非数值"            End If        Next          End WithEnd Sub  Sub TblSaveToNewBased(TblNum As Integer)    Dim doc As Document    Dim tbl As Table       Dim rowNum_start As Integer    Dim rowNum_end As Integer       Dim colNum_testVal As Integer   'testVal 所在列号    Dim colNum_isOK As Integer  '是否合格所在列号       Dim strCurTime As String    Dim newFilePath As String    Dim refFilePath As String       refFilePath = ThisDocument.Path & Application.PathSeparator &"测试报告模板.docx"       strCurTime = Year(Now) & Month(Now) & Day(Now) & Hour(Now)& Minute(Now)    '获取当前时间，命名新建Word文档    newFilePath = ThisDocument.Path & Application.PathSeparator &"测试报告" & strCurTime &".docx"       '打开doc    Set doc = Documents.Open(FileName:=refFilePath, Visible:=False,ReadOnly:=True)    'Set doc = Application.Documents.Add("D:\word\测试报告" & strCurTime & ".docx")    Set tbl = doc.Tables(TblNum)   ''''保存整个表格'    ThisDocument.Tables(TblNum).Range.Copy    '此时拷贝的是真个ActiveDocument为当前窗口文档''    doc.Tables(TblNum).Range.Paste 'ActiveDocument切换到doc，即模板文档'     doc.Words(1).Select'     Selection.Paste     ''''只保存测试数据列和是否合格列    With tbl        rowNum_start = 2        rowNum_end = .Rows.Count         colNum_isOK = .Columns.Count    '是否合格：倒数第一列        colNum_testVal = .Columns.Count - 1 '测试值：倒数第二列         For i = rowNum_start To rowNum_end             .Cell(i, colNum_testVal).Range.Text =Replace(ThisDocument.Tables(TblNum).Cell(i, colNum_testVal).Range.Text, Chr(13)& Chr(7), "")            .Cell(i, colNum_isOK).Range.Text =Replace(ThisDocument.Tables(TblNum).Cell(i, colNum_isOK).Range.Text, Chr(13)& Chr(7), "")        Next     End With'   '另存doc    doc.SaveAs2 FileName:=newFilePath  '调用saveas命令保存文档，根据实际，指定文档的保存路径和名称    doc.Close False   '关闭文件保存    Set doc = Nothing '释放对象    Set tbl = Nothing   '释放对象    MsgBox "新生成的文档保存在目录：" & newFilePathEnd Sub Private Sub TblSaveToExistedBased(TblNum AsInteger)    Dim doc As Document    Dim tbl As Table       Dim rowNum_start As Integer    Dim rowNum_end As Integer       Dim colNum_testVal As Integer   'testVal 所在列号    Dim colNum_isOK As Integer  '是否合格所在列号       Dim myDialog As FileDialog    Set myDialog = Application.FileDialog(msoFileDialogFilePicker)       myDialog.Filters.Clear    '清除所有文件筛选器中的项目    myDialog.Filters.Add "所有 WORD 文件", "*.doc,*.docx", 1    '增加筛选器的项目为所有WORD文件    myDialog.AllowMultiSelect = False    '不允许多项选择    If myDialog.Show = -1 Then    '确定        Application.ScreenUpdating = False               Set doc = Application.Documents.Open(FileName:=myDialog.SelectedItems(1),Visible:=False)  '.SelectedItems (1):选取的word文档        Set tbl = doc.Tables(TblNum)                       ''''只保存测试数据列和是否合格列        With tbl            rowNum_start = 2            rowNum_end = .Rows.Count               colNum_isOK = .Columns.Count    '是否合格：倒数第一列            colNum_testVal = .Columns.Count - 1 '测试值：倒数第二列               For i = rowNum_start To rowNum_end                   .Cell(i,colNum_testVal).Range.Text = Replace(ThisDocument.Tables(TblNum).Cell(i,colNum_testVal).Range.Text, Chr(13) & Chr(7), "")                .Cell(i,colNum_isOK).Range.Text = Replace(ThisDocument.Tables(TblNum).Cell(i,colNum_isOK).Range.Text, Chr(13) & Chr(7), "")            Next           End With           doc.Close True   '关闭文件保存        Set doc = Nothing '释放对象        Set tbl = Nothing   '释放对象          MsgBox "已保存到文档：" &myDialog.SelectedItems(1)    End If  End Sub''''''''''''''''''''''''''''表格1'''''''''''''''''''''''''''Private Sub Tbl1Check_Click()     Call TblCheckBased(1)   End Sub Private Sub Tbl1SaveToNew_Click()    Call TblSaveToNewBased(1) End Sub  Private Sub Tbl1SaveToExisted_Click()    TblSaveToExistedBased (1)End Sub  ''''''''''''''''''''''''''''表格2'''''''''''''''''''''''''''Private Sub Tbl2Check_Click() End Sub   Private Sub Tbl2SaveToNew_Click() End Sub  Private Sub Tbl2SaveToExisted_Click() End Sub Private Sub ToggleButton1_Click() End Sub   Sub CellDataCheck()'' CellDataCheck 宏''    Dim rowIdx, colIdx As Integer    Dim colNum_testVal As Integer   'testVal 所在列号    Dim colNum_isOK As Integer  '是否合格所在列号       Dim colNum_testValMin As Integer    'testVal有效最小值 所在列号    Dim colNum_testValMax As Integer    'testVal有效最大值 所在列号       Dim testStr As String    Dim testVal As Double    Dim testValMin As Double    Dim testValMax As Double       Dim curTbl As Table    Dim lProt As Long: Const Pwd As String = "123"       If ThisDocument.ProtectionType wdNoProtection Then        lProt = ThisDocument.ProtectionType        ThisDocument.Unprotect Password:=Pwd    End If       If Selection.Information(wdWithInTable) = True Then        rowIdx = Selection.Cells(1).RowIndex        colIdx = Selection.Cells(1).ColumnIndex               Set curTbl = Selection.Tables(1)  '选中当前表格               '开始校验        With curTbl                       '赋值使用的列号            colNum_isOK = colIdx + 1 '是否合格：倒数第一列            colNum_testVal = colIdx  'testVal：倒数第二列            colNum_testValMax = colIdx - 1  'testVal有效最大值：倒数第三列            colNum_testValMin = colIdx - 2  'testVal有效最小值：倒数第四列               testStr = Replace(.Cell(rowIdx, colNum_testVal).Range.Text, Chr(13)& Chr(7), "")                       If testStr = "" Then                MsgBox "测试值为空" '.Cell(i, 1).Range.Text & "测试值为空"            ElseIf IsNumeric(testStr) Then                testVal = Val(testStr)                testValMin =Val(Replace(.Cell(rowIdx, colNum_testValMin).Range.Text, Chr(13) & Chr(7),""))                testValMax =Val(Replace(.Cell(rowIdx, colNum_testValMax).Range.Text, Chr(13) & Chr(7),""))                               If testValMin                    .Cell(rowIdx, colNum_isOK).Range.Text= "合格"                Else                    .Cell(rowIdx,colNum_isOK).Range.Text = "不合格"                End If                              Else                MsgBox "测试值非数值"   '.Cell(i,1).Range.Text & "测试值非数值"            End If         End With               Else        MsgBox "The insertion point is not in a table."    End If     If lProt wdNoProtection Then        ThisDocument.Protect Type:=lProt, NoReset:=True, Password:=Pwd    End IfEnd Sub