'Log 関数を使った丸め関数

Option Explicit

Function LRoundUp(ByVal dfNumber As Double, ByVal iNum_Digits As Integer) As Double
    Dim dfNum2 As Double
    Dim iExponent As Integer
    Dim iShift As Integer

    If dfNumber = 0 Then
        LRoundUp = 0
        Exit Function
    End If

    dfNum2 = Abs(dfNumber)
    iExponent = Int(Log(dfNum2) / Log(10#))
    If dfNum2 >= (10 ^ (iExponent + 1)) Then
        iExponent = 13 - iExponent
    Else
        iExponent = 14 - iExponent
    End If
    If iExponent >= 0 Then
        dfNum2 = Int(dfNum2 * (10 ^ iExponent) + 0.5)
    Else
        dfNum2 = Int(dfNum2 / (10 ^ Abs(iExponent)) + 0.5)
    End If
    iShift = iExponent - iNum_Digits

    If iShift <= 0 Then
        If iExponent >= 0 Then
            LRoundUp = dfNum2 / (10 ^ iExponent) * Sgn(dfNumber)
        Else
            LRoundUp = dfNum2 * (10 ^ Abs(iExponent)) * Sgn(dfNumber)
        End If
    ElseIf iShift > 15 Then
        LRoundUp = 0
    Else
        If iNum_Digits > 0 Then
            LRoundUp = Int((dfNum2 - 1 + (10 ^ iShift)) / (10 ^ iShift)) _
                / (10 ^ iNum_Digits) * Sgn(dfNumber)
        Else
            LRoundUp = Int((dfNum2 - 1 + (10 ^ iShift)) / (10 ^ iShift)) _
                * (10 ^ Abs(iNum_Digits)) * Sgn(dfNumber)
        End If
    End If
End Function


Function LRoundDown(ByVal dfNumber As Double, ByVal iNum_Digits As Integer) As Double
    Dim dfNum2 As Double
    Dim iExponent As Integer
    Dim iShift As Integer

    If dfNumber = 0 Then
        LRoundDown = 0
        Exit Function
    End If

    dfNum2 = Abs(dfNumber)
    iExponent = Int(Log(dfNum2) / Log(10#))
    If dfNum2 >= (10 ^ (iExponent + 1)) Then
        iExponent = 13 - iExponent
    Else
        iExponent = 14 - iExponent
    End If
    If iExponent >= 0 Then
        dfNum2 = Int(dfNum2 * (10 ^ iExponent) + 0.5)
    Else
        dfNum2 = Int(dfNum2 / (10 ^ Abs(iExponent)) + 0.5)
    End If
    iShift = iExponent - iNum_Digits

    If iShift <= 0 Then
        If iExponent >= 0 Then
            LRoundDown = dfNum2 / (10 ^ iExponent) * Sgn(dfNumber)
        Else
            LRoundDown = dfNum2 * (10 ^ Abs(iExponent)) * Sgn(dfNumber)
        End If
    ElseIf iShift > 15 Then
        LRoundDown = 0
    Else
        If iNum_Digits > 0 Then
            LRoundDown = Int(dfNum2 / (10 ^ iShift)) _
                / (10 ^ iNum_Digits) * Sgn(dfNumber)
        Else
            LRoundDown = Int(dfNum2 / (10 ^ iShift)) _
                * (10 ^ Abs(iNum_Digits)) * Sgn(dfNumber)
        End If
    End If
End Function


Function LRound(ByVal dfNumber As Double, ByVal iNum_Digits As Integer) As Double
    Dim dfNum2 As Double
    Dim iExponent As Integer
    Dim iShift As Integer

    If dfNumber = 0 Then
        LRound = 0
        Exit Function
    End If

    dfNum2 = Abs(dfNumber)
    iExponent = Int(Log(dfNum2) / Log(10#))
    If dfNum2 >= (10 ^ (iExponent + 1)) Then
        iExponent = 13 - iExponent
    Else
        iExponent = 14 - iExponent
    End If
    If iExponent >= 0 Then
        dfNum2 = Int(dfNum2 * (10 ^ iExponent) + 0.5)
    Else
        dfNum2 = Int(dfNum2 / (10 ^ Abs(iExponent)) + 0.5)
    End If
    iShift = iExponent - iNum_Digits

    If iShift <= 0 Then
        If iExponent >= 0 Then
            LRound = dfNum2 / (10 ^ iExponent) * Sgn(dfNumber)
        Else
            LRound = dfNum2 * (10 ^ Abs(iExponent)) * Sgn(dfNumber)
        End If
    ElseIf iShift > 15 Then
        LRound = 0
    Else
        If iNum_Digits > 0 Then
            LRound = Int((Int(dfNum2 / (10 ^ (iShift - 1))) + 5) / 10) _
                / (10 ^ iNum_Digits) * Sgn(dfNumber)
        Else
            LRound = Int((Int(dfNum2 / (10 ^ (iShift - 1))) + 5) / 10) _
                * (10 ^ Abs(iNum_Digits)) * Sgn(dfNumber)
        End If
    End If
End Function


Function LJISRound(ByVal dfNumber As Double, ByVal iNum_Digits As Integer) As Double
    Dim dfNum2 As Double
    Dim dfNum3 As Double
    Dim dfNum4 As Double
    Dim dfNum5 As Double
    Dim iExponent As Integer
    Dim iShift As Integer
    Dim dfShift As Double
    Dim iUp As Integer

    If dfNumber = 0 Then
        LJISRound = 0
        Exit Function
    End If

    dfNum2 = Abs(dfNumber)
    iExponent = Int(Log(dfNum2) / Log(10#))
    If dfNum2 >= (10 ^ (iExponent + 1)) Then
        iExponent = 13 - iExponent
    Else
        iExponent = 14 - iExponent
    End If
    If iExponent >= 0 Then
        dfNum2 = Int(dfNum2 * (10 ^ iExponent) + 0.5)
    Else
        dfNum2 = Int(dfNum2 / (10 ^ Abs(iExponent)) + 0.5)
    End If
    iShift = iExponent - iNum_Digits

    If iShift <= 0 Then
        If iExponent >= 0 Then
            LJISRound = dfNum2 / (10 ^ iExponent) * Sgn(dfNumber)
        Else
            LJISRound = dfNum2 * (10 ^ Abs(iExponent)) * Sgn(dfNumber)
        End If
    ElseIf iShift > 15 Then
        LJISRound = 0
    Else
        dfShift = 10 ^ iShift
        dfNum3 = Int(dfNum2 / dfShift)
        dfNum4 = dfNum2 - dfNum3 * dfShift
        dfNum5 = dfShift / 2
        If dfNum4 < dfNum5 Then
            iUp = 0
        ElseIf dfNum4 > dfNum5 Then
            iUp = 1
        Else
            iUp = dfNum3 - Int(dfNum3 / 2) * 2
        End If
        If iNum_Digits > 0 Then
            LJISRound = (dfNum3 + iUp) / (10 ^ iNum_Digits) * Sgn(dfNumber)
        Else
            LJISRound = (dfNum3 + iUp) * (10 ^ Abs(iNum_Digits)) * Sgn(dfNumber)
        End If
    End If
End Function


Sub Test_Round()
    Dim x As Double
    Dim i As Long

    Debug.Print ""
    Debug.Print "--------------------"
    Debug.Print "RoundUp Test"
    Debug.Print "--------------------"

    x = 0.123450000000001
    i = 5
    Debug.Print x, i, LRoundUp(x, i)

    x = 0.12345
    i = 5
    Debug.Print x, i, LRoundUp(x, i)

    x = 123450000000001#
    i = -10
    Debug.Print x, i, LRoundUp(x, i)

    x = 123450000000000#
    i = -10
    Debug.Print x, i, LRoundUp(x, i)

    x = 0
    i = 5
    Debug.Print x, i, LRoundUp(x, i)

    x = 12345.0000000001
    i = 100
    Debug.Print x, i, LRoundUp(x, i)

    x = 12345.0000000001
    i = -100
    Debug.Print x, i, LRoundUp(x, i)


    Debug.Print ""
    Debug.Print "--------------------"
    Debug.Print "RoundDown Test"
    Debug.Print "--------------------"

    x = 0.12345
    i = 5
    Debug.Print x, i, LRoundDown(x, i)

    x = 0.123459999999999
    i = 5
    Debug.Print x, i, LRoundDown(x, i)

    x = 123450000000000#
    i = -10
    Debug.Print x, i, LRoundDown(x, i)

    x = 123459999999999#
    i = -10
    Debug.Print x, i, LRoundDown(x, i)

    x = 0
    i = 5
    Debug.Print x, i, LRoundDown(x, i)

    x = 12345.9999999999
    i = 100
    Debug.Print x, i, LRoundDown(x, i)

    x = 12345.9999999999
    i = -100
    Debug.Print x, i, LRoundDown(x, i)


    Debug.Print ""
    Debug.Print "--------------------"
    Debug.Print "Round Test"
    Debug.Print "--------------------"

    x = 0.123455
    i = 5
    Debug.Print x, i, LRound(x, i)

    x = 0.123454999999999
    i = 5
    Debug.Print x, i, LRound(x, i)

    x = 123455000000000#
    i = -10
    Debug.Print x, i, LRound(x, i)

    x = 123454999999999#
    i = -10
    Debug.Print x, i, LRound(x, i)

    x = 0
    i = 5
    Debug.Print x, i, LRound(x, i)

    x = 12345.9999999999
    i = 100
    Debug.Print x, i, LRound(x, i)

    x = 12345.9999999999
    i = -100
    Debug.Print x, i, LRound(x, i)


    Debug.Print ""
    Debug.Print "--------------------"
    Debug.Print "JISRound Test"
    Debug.Print "--------------------"

    x = 0.123455
    i = 5
    Debug.Print x, i, LJISRound(x, i)

    x = 0.123465
    i = 5
    Debug.Print x, i, LJISRound(x, i)

    x = 0.123455000000001
    i = 5
    Debug.Print x, i, LJISRound(x, i)

    x = 0.123465000000001
    i = 5
    Debug.Print x, i, LJISRound(x, i)

    x = 0.12345
    i = 5
    Debug.Print x, i, LJISRound(x, i)

    x = 0.123469999999999
    i = 5
    Debug.Print x, i, LJISRound(x, i)

    x = 123455000000000#
    i = -10
    Debug.Print x, i, LJISRound(x, i)

    x = 123465000000000#
    i = -10
    Debug.Print x, i, LJISRound(x, i)

    x = 123455000000001#
    i = -10
    Debug.Print x, i, LJISRound(x, i)

    x = 123465000000001#
    i = -10
    Debug.Print x, i, LJISRound(x, i)

    x = 123450000000000#
    i = -10
    Debug.Print x, i, LJISRound(x, i)

    x = 123459999999999#
    i = -10
    Debug.Print x, i, LJISRound(x, i)

    x = 0
    i = 5
    Debug.Print x, i, LJISRound(x, i)

    x = 12345.9999999999
    i = 100
    Debug.Print x, i, LJISRound(x, i)

    x = 12345.9999999999
    i = -100
    Debug.Print x, i, LJISRound(x, i)

End Sub

Sub Test_Round2()
    Dim x As Double
    Dim y As Double
    Dim i As Long
    Dim n As Long
    Dim oApp As Object
    Dim t As Date

    Debug.Print ""
    Debug.Print "----------------------"
    Debug.Print "LRound vs Excel.Round"
    Debug.Print "----------------------"

    Set oApp = Application
    x = 0.12355
    n = 10000

    t = Now
    For i = 1 To n
        y = LRound(x, 4)
    Next
    Debug.Print Format(Now - t, "nn:ss")

    t = Now
    For i = 1 To n
        y = oApp.Round(x, 4)
    Next
    Debug.Print Format(Now - t, "nn:ss")

End Sub

Function IntLog10(ByVal dfNumber As Double) As Integer
    Dim dfNum2 As Double
    Dim iExponent As Integer

    If dfNumber = 0 Then
        IntLog10 = 0
        Exit Function
    End If

    dfNum2 = Abs(dfNumber)
    iExponent = Int(Log(dfNum2) / Log(10#))
    If dfNum2 >= (10 ^ (iExponent + 1)) Then
        iExponent = iExponent + 1
    End If
    IntLog10 = iExponent
End Function

Sub Test_IntLog10()
    Dim x As Double
    x = 100
    Debug.Print Log(x) / Log(10#), IntLog10(x)
End Sub