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

 

'''''''''''''''''''''''''''

' 通用数据校验宏

'''''''''''''''''''''''''''

Dim gTestVal(100) As String

Sub 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), ""))

               

                If ThisDocument.ProtectionType <> wdNoProtection Then

                    lProt = ThisDocument.ProtectionType

                    ThisDocument.Unprotect Password:=Pwd

                End If

                'insert your code for content control additions here

                If testValMin <= testVal And testVal <= testValMax Then

                    .Cell(i, colNum_isOK).Range.Text = "合格"

                Else

                    .Cell(i, colNum_isOK).Range.Text = "不合格"

                End If

               

               

                If lProt <> wdNoProtection Then

                    ThisDocument.Protect Type:=lProt, NoReset:=True, Password:=Pwd

                End If

               

              

            Else

                MsgBox "测试值非数值"   '.Cell(i, 1).Range.Text & "测试值非数值"

            End If

        Next

   

   

    End With

End 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 "新生成的文档保存在目录：" & newFilePath

End Sub

 

Private Sub TblSaveToExistedBased(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 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 <= testVal And testVal <= testValMax Then

                    .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 If

End Sub