cad表格公式批量更新

striver

如图为cad钢筋工程量计算表，带背景的cad单元格中含有计算公式，更改其他单元格数值时，公式单元格的显示结果经常不会自动更新，使用该程序可以批量更新cad表格公式单元格的显示结果。

Sub cad表格公式更新xdcad()
  On Error GoTo ErrorHandler
  AppActivate Application.Caption '切换到当前文档
  
  Dim Ent As AcadEntity, Pnt As Variant
  Do
    ThisDrawing.Utility.GetEntity Ent, Pnt, vbCrLf & "选择表格"
    If TypeOf Ent Is AcadTable Then Exit Do
  Loop
  
  Ent.RegenerateTableSuppressed = True
  
  Dim celltextStr As String
  Dim myxsws As Integer
  Dim CellFormatStr As String
  Dim FormulaStr As String
  
  Dim I As Integer
  Dim J As Integer
  Dim RwH() As Double
  ReDim RwH(0 To Ent.Rows - 1)
  For I = 0 To Ent.Rows - 1
    RwH(I) = Ent.GetRowHeight(I)
  Next
  
  For I = 0 To Ent.Rows - 1
    For J = 0 To Ent.Columns - 1
      celltextStr = Trim(Ent.GetText(I, J))
      If Ent.GetHasFormula(I, J, 0) Then
        myxsws = xsws(celltextStr)
        CellFormatStr = "%pr" & myxsws & "%lu2"
        FormulaStr = Ent.GetFormula(I, J, 0)
        
        Ent.SetFormula I, J, 0, ""
        Ent.SetFormula I, J, 0, "=" & Mid(FormulaStr, 2, Len(FormulaStr) - 2)
        Ent.SetCellFormat I, J, CellFormatStr
        Ent.SetCellFormat I, J, CellFormatStr
      End If
    Next
    Ent.SetRowHeight I, RwH(I)
  Next
  Ent.RegenerateTableSuppressed = False
  
  ThisDrawing.Utility.Prompt "已更新表格。" & vbCrLf
  
ErrorHandler:
End Sub

'获取小数位数
Function xsws(numberStr As String) As Integer
    If InStr(numberStr, ".") = 0 Then
        xsws = 0
    ElseIf InStr(numberStr, ".") > 0 Then
        xsws = Len(numberStr) - InStr(numberStr, ".")
    End If
End Function

kmliro_2017

谢谢分享！！！！！

kmliro_2017

谢谢分享！！！！！

kmliro_2017

谢谢分享！！！！！

60ck

谢谢分享！
学习一下，看怎么使用