Word表格选定区域直接求和

wjhzhcn

主要实现三个功能：

1.对选择区域内有横向汇总关系的数据判断其是否满足求和关系，如果满足则简单提示，如果不满足则显示选择的行中具体某行不满足数据关系；
2.对选择区域内有纵向汇总 关系的数据判断其是否满足求和关系，如果满足则简单提Casting无误，否则逐列提示是否满足求和关系；
3.对选择区域内需要转换为负数的内容转换为负数（负数为转换为正数），自动判断其是否有小数点

[code=vb]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

Sub xxx()

MsgBox ActiveDocument.Tables(19).Range.Cells.Count



Dim xRng As Range

Dim iCell As Cell

iCount = 0

With ActiveDocument.Tables(19)
   
  Set xRng = .Range

    xRng.SetRange Start:=.Cell(3, 3).Range.Start, End:=.Cell(5, 3).Range.End
   
    For Each iCell In xRng.Cells
   
        If iCell.ColumnIndex >= xRng.Cells(1).ColumnIndex And iCell.ColumnIndex <= xRng.Cells(xRng.Cells.Count).ColumnIndex Then
        
           iCount = iCount + 1
        
        End If
   
    Next iCell
   
    MsgBox "计算出的应有单元格数" & iCount
   
    MsgBox xRng.Columns.Count
   
    xRng.Select
   
    MsgBox Selection.Columns.Count
   
   
   
End With


End Sub


Sub VSUM()

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

On Error Resume Next

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

Set xRng = Selection.Range

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

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

    iSum(i) = 0
   
Next i

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

yRng.Select

For Each iCell In xRng.Cells

        Set xCell = ActiveDocument.Range(Start:=iCell.Range.Start, End:=iCell.Range.End - 1)
        
        If CheckCellIdentity(ColumnNumber:=iCell.ColumnIndex, ColumnLBound:=xRng.Cells(1).ColumnIndex, ColumnUBound:=xRng.Cells(xRng.Cells.Count).ColumnIndex) = True Then
   
            Set yRng = ActiveDocument.Range(Start:=iCell.Range.End - 1, End:=iCell.Range.End - 1)
            
            yRng.Select
            
            If iCell.RowIndex = xRng.Cells(xRng.Cells.Count).RowIndex Then
   
               iSum(iCell.ColumnIndex - xRng.Cells(1).ColumnIndex) = iSum(iCell.ColumnIndex - xRng.Cells(1).ColumnIndex) - Replace(xCell.Text, "%", "")
               
               If Round(CDbl(iSum(iCell.ColumnIndex - xRng.Cells(1).ColumnIndex)), 2) <> 0 Then
               
                  iCell.Range.Shading.BackgroundPatternColor = wdColorRed
                  
               Else
               
                 iCell.Range.Shading.BackgroundPatternColor = wdColorAutomatic
               
               End If
               
            Else
              
                iSum(iCell.ColumnIndex - xRng.Cells(1).ColumnIndex) = iSum(iCell.ColumnIndex - xRng.Cells(1).ColumnIndex) + Replace(xCell.Text, "%", "")
               
            End If
        
       End If '先判断每个单元格是否都应该在选定范围
   
Next iCell

Msg = ""

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

    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:=vbExclamtion + vbOKOnly, Title:="求和结果"
Else

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

End If



End Sub





Sub HSUM()

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

On Error Resume Next

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

Dim xRng As Range
Dim yRng As Range

Set xRng = Selection.Range

With xRng

    ReDim iSum(.Rows.Count - 1)
   
    For i = 0 To xRng.Rows.Count - 1
   
        iSum(i) = 0
        
    Next i

End With

For Each iCell In xRng.Cells

        Set xCell = ActiveDocument.Range(Start:=iCell.Range.Start, End:=iCell.Range.End - 1)
        
        If CheckCellIdentity(ColumnNumber:=iCell.ColumnIndex, ColumnLBound:=xRng.Cells(1).ColumnIndex, ColumnUBound:=xRng.Cells(xRng.Cells.Count).ColumnIndex) = True Then
   
            Set yRng = ActiveDocument.Range(Start:=iCell.Range.End - 1, End:=iCell.Range.End - 1)
            
            yRng.Select
            
            If iCell.ColumnIndex = xRng.Cells(xRng.Cells.Count).ColumnIndex Then
   
               iSum(iCell.RowIndex - xRng.Cells(1).RowIndex) = iSum(iCell.RowIndex - xRng.Cells(1).RowIndex) - xCell.Text
               
               If Round(CDbl(iSum(iCell.RowIndex - xRng.Cells(1).RowIndex)), 2) <> 0 Then
               
                  iCell.Range.Shading.BackgroundPatternColor = wdColorYellow
                  
               Else
               
                 iCell.Range.Shading.BackgroundPatternColor = wdColorAutomatic
               
               End If
               
            Else
              
                iSum(iCell.RowIndex - xRng.Cells(1).RowIndex) = iSum(iCell.RowIndex - xRng.Cells(1).RowIndex) + xCell.Text
               
            End If
            
        End If
   
Next iCell

Msg = ""

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

  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:=vbExlamation + vbOKOnly, Title:="求和结果"
   
Else

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

End If


End Sub


Sub To_negative()

On Error Resume Next

Dim xCell As Range
Dim iCell As Cell



For Each iCell In Selection.Cells

      iSum = 0

       Set xCell = ActiveDocument.Range(Start:=iCell.Range.Start, End:=iCell.Range.End - 1)
     
       iSum = 0 - xCell.Text
   
       iCell.Range.Text = Format(iSum, "##,###.00;(##,###.00)")
   
Next iCell



End Sub
[/code]

oylw

好长啊！{:soso_e114:}