office宏-校验word表格数据

Function CheckCellIdentity(ColumnNumber As Integer, ColumnLBound As Integer, ColumnUBound As Integer) As Boolean

     CheckCellIdentity = False
     
     On Error GoTo iExit
     
     If ColumnNumber >= ColumnLBound And ColumnNumber <= ColumnUBound Then
     
        CheckCellIdentity = True
     
     End If

iExit:

End Function

Function YSUM(xRng As Cells)

'本代码的作用是纵向求和，自动将选定区域中的最后一行数字转化为其相反数与选定区域的其他数据相加，如果结果为0说明Casting 正确，如果结果不为0，说明Casting有问题

On Error Resume Next

Dim xCell As Range
Dim yRng As Range
Dim iCell As Cell
Dim iSum() As Variant
Dim xChoice As Integer

ReDim iSum(xRng.Item(xRng.Count).ColumnIndex - xRng.Item(1).ColumnIndex + 1)

For i = 0 To xRng.Item(xRng.Count).ColumnIndex - xRng.Item(1).ColumnIndex

iSum(i) = 0

Next i

Set yRng = ActiveDocument.Range(Start:=xRng.Item(1).Range.Start, End:=xRng.Item(1).Range.Start)

yRng.Select

For Each iCell In xRng

    Set xCell = ActiveDocument.Range(Start:=iCell.Range.Start, End:=iCell.Range.End - 1)
    
    If CheckCellIdentity(ColumnNumber:=iCell.ColumnIndex, ColumnLBound:=xRng.Item(1).ColumnIndex, ColumnUBound:=xRng.Item(xRng.Count).ColumnIndex) = True Then

        Set yRng = ActiveDocument.Range(Start:=iCell.Range.End - 1, End:=iCell.Range.End - 1)
        
        yRng.Select
        
       
        
        If iCell.RowIndex <> xRng.Item(xRng.Count).RowIndex Then
          
            iSum(iCell.ColumnIndex - xRng.Item(1).ColumnIndex) = iSum(iCell.ColumnIndex - xRng.Item(1).ColumnIndex) + Replace(xCell.Text, "%", "")
           
        End If
        
        
         If iCell.RowIndex = xRng.Item(xRng.Count).RowIndex Then

           iSum(iCell.ColumnIndex - xRng.Item(1).ColumnIndex) = iSum(iCell.ColumnIndex - xRng.Item(1).ColumnIndex) - Replace(xCell.Text, "%", "")
           
           If Round(CDbl(iSum(iCell.ColumnIndex - xRng.Item(1).ColumnIndex)), 2) <> 0 Then
           
              
              If iCell.Range.Comments.Count = 1 Then iCell.Range.Comments.Item(1).Delete
              
              iCell.Range.Comments.Add iCell.Range, "Casting Error:" & Format(iSum(iCell.ColumnIndex - xRng.Item(1).ColumnIndex), "Standard")
              
           Else

             
             If iCell.Range.Comments.Count = 1 Then iCell.Range.Comments.Item(1).Delete
           
           End If
           
           
        End If
    
   End If

Next iCell

Exit Function

Msg = “”

For i = LBound(iSum) To UBound(iSum)

If Round(CDbl(iSum(i)), 2) <> 0 Then

    Msg = Msg & "选择区域内第" & i + 1 & "列的Casting结果是:" & Format(iSum(i), "Standard") & Chr(10) & Chr(13)

End If

Next i

If Msg <> “” Then

MsgBox Prompt:=Msg, Buttons:=vbExclamation + vbOKOnly, Title:="求和结果"

Else

MsgBox Prompt:="所有列Casting无误", Buttons:=vbInformation + vbOKOnly, Title:="求和结果"

End If

End Function

Function XSUM(xRng As Cells)

'本代码的作用是横向求和，自动将选定区域中的最后一行数字转化为其相反数与选定区域的其他数据相加，如果结果为0说明Casting 正确，如果结果不为0，说明Casting有问题

On Error Resume Next

Dim xCell As Range
Dim iCell As Cell
Dim iSum() As Variant

Dim yRng As Range

With xRng

ReDim iSum(xRng.Item(xRng.Count).RowIndex - xRng.Item(1).RowIndex + 1)

For i = 0 To xRng.Item(xRng.Count).RowIndex - xRng.Item(1).RowIndex

    iSum(i) = 0
    
Next i

End With

For Each iCell In xRng

    Set xCell = ActiveDocument.Range(Start:=iCell.Range.Start, End:=iCell.Range.End - 1)
    
    If CheckCellIdentity(ColumnNumber:=iCell.ColumnIndex, ColumnLBound:=xRng.Item(1).ColumnIndex, ColumnUBound:=xRng.Item(xRng.Count).ColumnIndex) = True Then

        Set yRng = ActiveDocument.Range(Start:=iCell.Range.End - 1, End:=iCell.Range.End - 1)
        
        yRng.Select
        
        If iCell.ColumnIndex = xRng.Item(xRng.Count).ColumnIndex Then

           iSum(iCell.RowIndex - xRng.Item(1).RowIndex) = iSum(iCell.RowIndex - xRng.Item(1).RowIndex) - xCell.Text
           
           If Round(CDbl(iSum(iCell.RowIndex - xRng.Item(1).RowIndex)), 2) <> 0 Then
        
              
              If iCell.Range.Comments.Count = 1 Then iCell.Range.Comments(1).Delete
              
              iCell.Range.Comments.Add iCell.Range, "Casting error:" & Format(iSum(iCell.RowIndex - xRng.Item(1).RowIndex), "Standard")
              
           Else
                           
             If iCell.Range.Comments.Count = 1 Then iCell.Range.Comments(1).Delete
           
           End If
           
        Else
          
            iSum(iCell.RowIndex - xRng.Item(1).RowIndex) = iSum(iCell.RowIndex - xRng.Item(1).RowIndex) + xCell.Text
           
        End If
        
    End If

Next iCell

Exit Function

Msg = “”

For i = LBound(iSum) To UBound(iSum)

If Round(CDbl(iSum(i)), 2) <> 0 Then

Msg = Msg & "选择区域内第" & i + 1 & "行的Casting结果是:" & Format(iSum(i), "Standard") & Chr(10) & Chr(13)

End If

Next i

If Msg <> “” Then

MsgBox Prompt:=Msg, Buttons:=vbExclamation + vbOKOnly, Title:="求和结果"

Else

MsgBox Prompt:="恭喜，所有行Casting无误", Buttons:=vbInformation + vbOKOnly, Title:="求和结果"

End If

End Function

Sub 校验表格数据()

'本代码的作用是校验表格数据
On Error Resume Next

Dim WdRng As Word.Range
Dim rowsCount
Dim columnCount
Dim firstRowCell
Dim lastRowCell
Dim xRng As Cells

Set WdRng = Application.ActiveDocument.Range

For iTabNo = 1 To WdRng.Tables.Count
    rowsCount = WdRng.Tables(iTabNo).Range.Rows.Count
    columnCount = WdRng.Tables(iTabNo).Range.Columns.Count
    
    For i = columnCount To 1 Step -1
        firstRowCell = WdRng.Tables(iTabNo).Cell(1, i)
        If firstRowCell <> "" Then
            Exit For
        End If
    
    Next

    firstRowCell = Left(firstRowCell, Len(firstRowCell) - 2)
    firstRowCell = Left(firstRowCell, 1) + Right(firstRowCell, 1)
    

    lastRowCell = WdRng.Tables(iTabNo).Cell(rowsCount, 1)
    lastRowCell = Left(lastRowCell, Len(lastRowCell) - 2)
    lastRowCell = Left(lastRowCell, 1) + Right(lastRowCell, 1)

    Set xRng = WdRng.Tables(iTabNo).Range.Cells
          
    If lastRowCell = "合计" Then
        Call YSUM(xRng)
    ElseIf firstRowCell = "合计" Then
        Call XSUM(xRng)
    End If

Next iTabNo

End Sub