设置单元格小数位数

admin

Sub B设置单元格小数位数()
    Dim DecimalPlaces As Integer
    Dim cell As Range
    Dim FormulaText As String
    Dim UpdatedFormula As String
    Dim ValueCell As Variant
    Dim re As Object
    Dim RoundingType As Integer
    Dim RoundingChoice As String

    ' 创建正则表达式对象
    Set re = CreateObject("VBScript.RegExp")
    re.Global = True

    ' 确保至少选择了一个单元格
    If Selection.Cells.Count = 0 Then
        MsgBox "请先选择需要处理的单元格", vbExclamation, "未选中单元格"
        Exit Sub
    ElseIf Selection.Cells.Count = 1 Then
        MsgBox "请选择至少两个单元格进行处理", vbExclamation, "选择单元格数不足"
        Exit Sub
    End If

    ' 提示用户输入所需的小数位数
    Do
        DecimalPlaces = InputBox("请输入小数位数（0至6）:", "设置小数位数", 2)
    Loop Until DecimalPlaces >= 0 And DecimalPlaces <= 6

    ' 提示用户选择取舍方式
    Do
        RoundingChoice = InputBox("请选择取舍方式:" & vbCrLf & "1. 向上取整" & vbCrLf & "2. 四舍五入" & vbCrLf & "3. 向下取整", "选择取舍方式", "2")
    Loop Until RoundingChoice = "1" Or RoundingChoice = "2" Or RoundingChoice = "3"

    ' 将RoundingChoice转换为整数
    RoundingType = CInt(RoundingChoice)

    ' 循环处理选中的每一个单元格
    For Each cell In Selection
        ' 判断单元格是否包含公式
        If cell.HasFormula Then
            ' 获取原公式
            FormulaText = cell.Formula
            ' 检查是否已经包含ROUND函数
            re.Pattern = "^=\s*ROUND\s*\(\s*(.*?),\s*(\d+)\s*\)\s*$"
            If re.Test(FormulaText) Then
                ' 获取ROUND函数中的数值和位数
                Dim formulaValue As String
                Dim existingDecimalPlaces As Integer

                formulaValue = re.Execute(FormulaText)(0).SubMatches(0)
                existingDecimalPlaces = CInt(re.Execute(FormulaText)(0).SubMatches(1))

                ' 如果原始位数与新位数不符，进行修改
                If existingDecimalPlaces <> DecimalPlaces Then
                    ' 更新公式，将ROUND函数的位数改为新定义的位数
                    UpdatedFormula = "=ROUND(" & formulaValue & "," & DecimalPlaces & ")"
                    ' 将更新后的公式应用到单元格
                    cell.Formula = UpdatedFormula
                End If
            Else
                ' 如果没有ROUND函数，添加新的ROUND函数
                UpdatedFormula = "=ROUND(" & Mid(FormulaText, 2) & "," & DecimalPlaces & ")"
                cell.Formula = UpdatedFormula
            End If
        Else
            ' 单元格不包含公式，判断是否为数值
            If IsNumeric(cell.Value) Then
                ' 获取单元格数值
                ValueCell = cell.Value
                ' 对数值进行取舍
                cell.Value = WorksheetFunction.Round(ValueCell, DecimalPlaces)
            End If
        End If

        ' 设置单元格格式，显示尾数0
        Dim formatString As String
        If DecimalPlaces > 0 Then
            formatString = "0." & String(DecimalPlaces, "0")
        Else
            formatString = "0"
        End If
        cell.NumberFormat = formatString
    Next cell
End Sub