Round 四捨五入函數增益集

by chijanzen on 六月 25th, 2009 | View: 3,040 views

Tags

round

Comments (2)

索引	H0074
主題	Round 四捨五入函數增益集
版本	>= 11.0(Office 2003)
說明	工作中常使用到Round 函數將所計算的值四捨五入，每次都要打 "=Rornd(..." 還蠻麻煩的於是作了這個增益集，用法跟取小數點幾位的工具按鈕一樣方便好用。請執行 InstallAddin.xls 來安裝增益集
參考

Code

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.CommandBars("Formatting").Controls("(,2)").Delete
    Application.CommandBars("Formatting").Controls("(,1)").Delete
    Application.CommandBars("Formatting").Controls("(,0)").Delete
    Err.Clear
End Sub
　

Private Sub Workbook_Open()
Call CreateControl
End Sub
　

Code

Sub CreateControl()
    Dim objBtn As CommandBarButton
    'Begin insert IstRorun0
    On Error Resume Next
    Application.CommandBars("Formatting").Controls("(,2)").Delete
    Set objBtn = Application.CommandBars("Formatting").Controls.Add(Type:= _
            msoControlButton, Before:=15, Temporary:=True)
    With objBtn
        .Caption = "(,2)"
        .Tag = 2
        .OnAction = "Insert_Rounding"
        .BeginGroup = False
        .TooltipText = "四捨五入至小數第二位"
        .Style = msoButtonIconAndCaption
        .FaceId = 97
    End With
    Application.CommandBars("Formatting").Controls("(,1)").Delete
    Set objBtn = Application.CommandBars("Formatting").Controls.Add(Type:= _
            msoControlButton, Before:=15, Temporary:=True)
    With objBtn
        .Caption = "(,1)"
        .Tag = 1
        .OnAction = "Insert_Rounding"
        .BeginGroup = False
        .TooltipText = "四捨五入至小數第一位"
        .Style = msoButtonIconAndCaption
        .FaceId = 97
    End With
    Application.CommandBars("Formatting").Controls("(,0)").Delete
    Set objBtn = Application.CommandBars("Formatting").Controls.Add(Type:= _
            msoControlButton, Before:=15, Temporary:=True)
    With objBtn
        .Caption = "(,0)"
        .Tag = 0
        .OnAction = "Insert_Rounding"
        .BeginGroup = False
        .TooltipText = "四捨五入無小數位"
        .Style = msoButtonIconAndCaption
        .FaceId = 97
    End With
    Err.Clear
    On Error GoTo 0

End Sub
　

Sub Insert_Rounding()
    Dim Orig_formula As String
    Dim formulaRg As Range
    Dim formcell As Range
    Dim ctl As CommandBarControl
    Set ctl = CommandBars.ActionControl
    For Each formcell In Selection
    '判斷儲存格是否為公式
        If formcell.HasFormula Then
            Orig_formula = formcell.Formula
            Orig_formula = Mid(Orig_formula, 1, 1) & "round(" & _
                    Mid(Orig_formula, 2) & "," & ctl.Tag & ")"
            formcell.Formula = Orig_formula
        End If
    Next
End Sub
　

Code

附件內有兩個檔案，請解壓縮到同一資料夾內，請執行安裝程式

Code

Popularity: 56%

About the Author

網路化名: chijanzen、中國龍、邪兵衛經歷: 第二屆微軟社群之星第三屆微軟「最有價值專家」第五屆微軟「最有價值專家」

Leave a Comment »2 Comments

Reply » ming 三月 15, 2010

想請問一下
若想在儲存格中使用VBA的round()函數要怎麼使用（多人使用的環境下）
之前有用過增益集
不過自己的電腦可以使用
換一台後，數據重新輸入後就會無法使用該增益集
Reply » zanjero 十月 16, 2009

我也写了一个，供参考：

Public Function mYX(X, n As Integer)  'n为有效数字位数

Dim jk, j
Dim Y As Single
Dim temp As String
If X = "" Or (Not Application.WorksheetFunction.IsNumber(X)) Then mYX = "?Value!": Exit Function
X = Val(X)

If X <= 0 Or n < 1 Then mYX = X: Exit Function
If X < 1 Then
      j = 1

      Do
         temp = CStr(X)
         j = j + 1
      Loop Until Val(Mid$(temp, j, 1)) > 0
      j = j + n
      X = X * 10 ^ j
      jk = Len(CStr(Int(X))) - n
      Y = X / 10 ^ jk + 0.5
      mYX = Int(Y) * 10 ^ jk / 10 ^ j
      X = X / 10 ^ j
Else
      jk = Len(CStr(Int(X))) - n
      Y = X / 10 ^ jk + 0.5
      mYX = Int(Y) * 10 ^ jk
End If

End Function

Get a GravatarLeave a Reply

Blue Green Grey Orange Purple Red

chijanzen 雜貨舖

Round 四捨五入函數增益集