كيفية التقريب في MS Access، VBA

StackOverflow https://stackoverflow.com/questions/137114

سؤال

ما هي أفضل طريقة للتقريب في VBA Access؟

طريقتي الحالية تستخدم طريقة Excel

Excel.WorksheetFunction.Round(...

لكني أبحث عن وسيلة لا تعتمد على برنامج Excel.

هل كانت مفيدة؟

المحلول

كن حذرًا، تستخدم الدالة VBA Round تقريب Banker، حيث تقوم بتقريب 0.5 إلى رقم زوجي، كما يلي: 

Round (12.55, 1) would return 12.6 (rounds up) 
Round (12.65, 1) would return 12.6 (rounds down) 
Round (12.75, 1) would return 12.8 (rounds up)

بينما يتم تقريب دالة ورقة عمل Excel دائمًا بمقدار 0.5 لأعلى.

لقد أجريت بعض الاختبارات ويبدو أن التقريب بمقدار 0.5 لأعلى (التقريب المتماثل) يُستخدم أيضًا في تنسيق الخلايا، وكذلك لتقريب عرض العمود (عند استخدام تنسيق الرقم العام).لا يبدو أن علامة "الدقة كما هو معروض" تقوم بأي تقريب بحد ذاتها، فهي تستخدم فقط النتيجة المقربة لتنسيق الخلية.

لقد حاولت تنفيذ وظيفة SymArith من Microsoft في VBA للتقريب، ولكن وجدت أن الإصلاح به خطأ عند محاولة إعطائه رقمًا مثل 58.55؛الدالة تعطي نتيجة 58.5 بدلاً من 58.6.ثم اكتشفت أخيرًا أنه يمكنك استخدام وظيفة Excel Worksheet Round، كما يلي:

التطبيق.جولة (58.55، 1)

سيسمح لك هذا بإجراء التقريب العادي في VBA، على الرغم من أنه قد لا يكون بنفس سرعة بعض الوظائف المخصصة.أدرك أن هذا قد انتهى من السؤال، لكنني أردت إدراجه من أجل اكتماله.

نصائح أخرى

للتوسع قليلاً في الإجابة المقبولة:

"تعمل الدالة Round من التقريب إلى الزوجي، وهو ما يختلف من التقريب إلى الأكبر."
--مايكروسوفت

يتم تقريب التنسيق دائمًا إلى الأعلى.

  Debug.Print Round(19.955, 2)
  'Answer: 19.95

  Debug.Print Format(19.955, "#.00")
  'Answer: 19.96

أسك2000:أخطاء التقريب عند استخدام أرقام الفاصلة العائمة: http://support.microsoft.com/kb/210423

أسك2000:كيفية تقريب رقم لأعلى أو لأسفل بالزيادة المرغوبة: http://support.microsoft.com/kb/209996

وظيفة الجولة: http://msdn2.microsoft.com/en-us/library/se6f2zfx.aspx

كيفية تنفيذ إجراءات التقريب المخصصة: http://support.microsoft.com/kb/196652

في سويسرا، وعلى وجه الخصوص في صناعة التأمين، يتعين علينا استخدام العديد من قواعد التقريب، اعتمادًا على ما إذا كان سيتم صرف المبلغ أو المنفعة وما إلى ذلك.

أستخدم الوظيفة حاليًا

Function roundit(value As Double, precision As Double) As Double
    roundit = Int(value / precision + 0.5) * precision
End Function

والذي يبدو أنه يعمل بشكل جيد

تعد كل من Int وFix من وظائف التقريب المفيدة، والتي تمنحك الجزء الصحيح من الرقم.

يتم تقريب Int دائمًا للأسفل - Int(3.5) = 3، Int(-3.5) = -4

يتم تقريب الإصلاح دائمًا نحو الصفر - Fix(3.5) = 3، Fix(-3.5) = -3

هناك أيضًا وظائف الإكراه، على وجه الخصوص CInt وCLng، التي تحاول إجبار رقم على نوع صحيح أو نوع طويل (الأعداد الصحيحة تتراوح بين -32,768 و32,767، والأطوال تتراوح بين -2,147,483,648 و2,147,483,647).سيتم تقريبهما نحو أقرب رقم صحيح، أي التقريب بعيدًا عن الصفر من .5 - CInt(3.5) = 4، Cint(3.49) = 3، CInt(-3.5) = -4، إلخ.

1 place = INT(number x 10 + .5)/10
3 places = INT(number x 1000 + .5)/1000

وما إلى ذلك. ستجد غالبًا أن الحلول المبتذلة مثل هذه هي أسرع بكثير من استخدام وظائف Excel، لأن VBA يبدو أنه يعمل في مساحة ذاكرة مختلفة.

على سبيل المثال If A > B Then MaxAB = A Else MaxAB = B أسرع بنحو 40 مرة من استخدام ExcelWorksheetFunction.Max

لسوء الحظ، فإن الوظائف الأصلية لـ VBA التي يمكنها إجراء التقريب إما مفقودة أو محدودة أو غير دقيقة أو بها أخطاء، وكل منها يعالج أسلوب تقريب واحد فقط.الجانب الإيجابي هو أنهم سريعون، وقد يكون ذلك مهمًا في بعض المواقف.

ومع ذلك، غالبًا ما تكون الدقة إلزامية، ومع سرعة أجهزة الكمبيوتر اليوم، من الصعب ملاحظة معالجة أبطأ قليلاً، وليس في الواقع لمعالجة القيم الفردية.تعمل جميع الوظائف الموجودة في الروابط أدناه عند حوالي 1 ميكروثانية.

يمكن العثور هنا على المجموعة الكاملة من الوظائف - لجميع طرق التقريب الشائعة، وجميع أنواع بيانات VBA، ولأي قيمة، وعدم إرجاع القيم غير المتوقعة:

تقريب القيم لأعلى أو لأسفل بمقدار 4/5 أو إلى أرقام مهمة (EE)

أو هنا:

تقريب القيم لأعلى أو لأسفل بمقدار 4/5 أو إلى أرقام مهمة (CodePlex)

الكود فقط على GitHub:

VBA.Round

وهي تغطي طرق التقريب العادية:

  • التقريب للأسفل، مع خيار تقريب القيم السالبة نحو الصفر

  • التقريب للأعلى، مع خيار تقريب القيم السالبة بعيدًا عن الصفر

  • التقريب بمقدار 4/5، إما بعيدًا عن الصفر أو حتى (تقريب المصرفي)

  • قم بالتقريب إلى عدد من الأرقام المهمة

تقبل الوظائف الثلاث الأولى جميع أنواع البيانات الرقمية، بينما توجد الأخيرة في ثلاثة أنواع - للعملة، والعشري، والمزدوج على التوالي.

تقبل جميعها عددًا محددًا من الكسور العشرية - بما في ذلك العدد السلبي الذي سيتم تقريبه إلى العشرات والمئات وما إلى ذلك.أولئك الذين لديهم Variant كنوع الإرجاع سيعيدون Null للإدخال غير المفهوم

يتم أيضًا تضمين وحدة اختبار للاختبار والتحقق من الصحة.

يوجد مثال هنا - للتقريب الشائع 4/5.يرجى دراسة التعليقات المضمنة للحصول على التفاصيل الدقيقة والطريقة CDec يتم استخدامه لتجنب أخطاء البت.

' Common constants.
'
Public Const Base10     As Double = 10

' Rounds Value by 4/5 with count of decimals as specified with parameter NumDigitsAfterDecimals.
'
' Rounds to integer if NumDigitsAfterDecimals is zero.
'
' Rounds correctly Value until max/min value limited by a Scaling of 10
' raised to the power of (the number of decimals).
'
' Uses CDec() for correcting bit errors of reals.
'
' Execution time is about 1µs.
'
Public Function RoundMid( _
    ByVal Value As Variant, _
    Optional ByVal NumDigitsAfterDecimals As Long, _
    Optional ByVal MidwayRoundingToEven As Boolean) _
    As Variant

    Dim Scaling     As Variant
    Dim Half        As Variant
    Dim ScaledValue As Variant
    Dim ReturnValue As Variant

    ' Only round if Value is numeric and ReturnValue can be different from zero.
    If Not IsNumeric(Value) Then
        ' Nothing to do.
        ReturnValue = Null
    ElseIf Value = 0 Then
        ' Nothing to round.
        ' Return Value as is.
        ReturnValue = Value
    Else
        Scaling = CDec(Base10 ^ NumDigitsAfterDecimals)

        If Scaling = 0 Then
            ' A very large value for Digits has minimized scaling.
            ' Return Value as is.
            ReturnValue = Value
        ElseIf MidwayRoundingToEven Then
            ' Banker's rounding.
            If Scaling = 1 Then
                ReturnValue = Round(Value)
            Else
                ' First try with conversion to Decimal to avoid bit errors for some reals like 32.675.
                ' Very large values for NumDigitsAfterDecimals can cause an out-of-range error 
                ' when dividing.
                On Error Resume Next
                ScaledValue = Round(CDec(Value) * Scaling)
                ReturnValue = ScaledValue / Scaling
                If Err.Number <> 0 Then
                    ' Decimal overflow.
                    ' Round Value without conversion to Decimal.
                    ReturnValue = Round(Value * Scaling) / Scaling
                End If
            End If
        Else
            ' Standard 4/5 rounding.
            ' Very large values for NumDigitsAfterDecimals can cause an out-of-range error 
            ' when dividing.
            On Error Resume Next
            Half = CDec(0.5)
            If Value > 0 Then
                ScaledValue = Int(CDec(Value) * Scaling + Half)
            Else
                ScaledValue = -Int(-CDec(Value) * Scaling + Half)
            End If
            ReturnValue = ScaledValue / Scaling
            If Err.Number <> 0 Then
                ' Decimal overflow.
                ' Round Value without conversion to Decimal.
                Half = CDbl(0.5)
                If Value > 0 Then
                    ScaledValue = Int(Value * Scaling + Half)
                Else
                    ScaledValue = -Int(-Value * Scaling + Half)
                End If
                ReturnValue = ScaledValue / Scaling
            End If
        End If
        If Err.Number <> 0 Then
            ' Rounding failed because values are near one of the boundaries of type Double.
            ' Return value as is.
            ReturnValue = Value
        End If
    End If

    RoundMid = ReturnValue

End Function

إذا كنت تتحدث عن التقريب إلى قيمة عددية (وليس التقريب إلى ن المنازل العشرية)، هناك دائمًا طريقة المدرسة القديمة:

return int(var + 0.5)

(يمكنك جعل هذا العمل من أجل ن المنازل العشرية أيضًا، لكنها بدأت تصبح فوضوية بعض الشيء)

ذكر لانس بالفعل تقريب الميراث bug في تنفيذ VBA.لذلك أحتاج إلى وظيفة تقريب حقيقية في تطبيق VB6.هنا واحد أستخدمه.إنه يعتمد على ما وجدته على الويب كما هو موضح في التعليقات.

' -----------------------------------------------------------------------------
' RoundPenny
'
' Description:
'    rounds currency amount to nearest penny
'
' Arguments:
'    strCurrency        - string representation of currency value
'
' Dependencies:
'
' Notes:
' based on RoundNear found here:
' http://advisor.com/doc/08884
'
' History:
' 04/14/2005 - WSR : created
'
Function RoundPenny(ByVal strCurrency As String) As Currency

         Dim mnyDollars    As Variant
         Dim decCents      As Variant
         Dim decRight      As Variant
         Dim lngDecPos     As Long

1        On Error GoTo RoundPenny_Error

         ' find decimal point
2        lngDecPos = InStr(1, strCurrency, ".")

         ' if there is a decimal point
3        If lngDecPos > 0 Then

            ' take everything before decimal as dollars
4           mnyDollars = CCur(Mid(strCurrency, 1, lngDecPos - 1))

            ' get amount after decimal point and multiply by 100 so cents is before decimal point
5           decRight = CDec(CDec(Mid(strCurrency, lngDecPos)) / 0.01)

            ' get cents by getting integer portion
6           decCents = Int(decRight)

            ' get leftover
7           decRight = CDec(decRight - decCents)

            ' if leftover is equal to or above round threshold
8           If decRight >= 0.5 Then

9              RoundPenny = mnyDollars + ((decCents + 1) * 0.01)

            ' if leftover is less than round threshold
10          Else

11             RoundPenny = mnyDollars + (decCents * 0.01)

12          End If

         ' if there is no decimal point
13       Else

            ' return it
14          RoundPenny = CCur(strCurrency)

15       End If

16       Exit Function

RoundPenny_Error:

17       Select Case Err.Number

            Case 6

18             Err.Raise vbObjectError + 334, c_strComponent & ".RoundPenny", "Number '" & strCurrency & "' is too big to represent as a currency value."

19          Case Else

20             DisplayError c_strComponent, "RoundPenny"

21       End Select

End Function
' ----------------------------------------------------------------------------- 

VBA.Round(1.23342, 2) // will return 1.23

لحل مشكلة عدم إضافة تقسيمات العملات إلى المبلغ الذي تم تقسيمها منه في الأصل، قمت بإنشاء وظيفة يحددها المستخدم.

Function PennySplitR(amount As Double, Optional splitRange As Variant, Optional index As Integer = 0, Optional n As Integer = 0, Optional flip As Boolean = False) As Double
' This Excel function takes either a range or an index to calculate how to "evenly" split up dollar amounts
' when each split amount must be in pennies.  The amounts might vary by a penny but the total of all the
' splits will add up to the input amount.

' Splits a dollar amount up either over a range or by index
' Example for passing a range: set range $I$18:$K$21 to =PennySplitR($E$15,$I$18:$K$21) where $E$15 is the amount and $I$18:$K$21 is the range
'                              it is intended that the element calling this function will be in the range
' or to use an index and total items instead of a range: =PennySplitR($E$15,,index,N)
' The flip argument is to swap rows and columns in calculating the index for the element in the range.

' Thanks to: http://stackoverflow.com/questions/5559279/excel-cell-from-which-a-function-is-called for the application.caller.row hint.
Dim evenSplit As Double, spCols As Integer, spRows As Integer
If (index = 0 Or n = 0) Then
    spRows = splitRange.Rows.count
    spCols = splitRange.Columns.count
    n = spCols * spRows
    If (flip = False) Then
       index = (Application.Caller.Row - splitRange.Cells.Row) * spCols + Application.Caller.Column - splitRange.Cells.Column + 1
     Else
       index = (Application.Caller.Column - splitRange.Cells.Column) * spRows + Application.Caller.Row - splitRange.Cells.Row + 1
    End If
 End If
 If (n < 1) Then
    PennySplitR = 0
    Return
 Else
    evenSplit = amount / n
    If (index = 1) Then
            PennySplitR = Round(evenSplit, 2)
        Else
            PennySplitR = Round(evenSplit * index, 2) - Round(evenSplit * (index - 1), 2)
    End If
End If
End Function

لقد استخدمت ما يلي بسيط وظيفة لتقريب بلدي العملات كما هو الحال في شركتنا نحن دائماً جمع الشمل.

Function RoundUp(Number As Variant)
   RoundUp = Int(-100 * Number) / -100
   If Round(Number, 2) = Number Then RoundUp = Number
End Function

ولكن هذا سيؤدي دائمًا إلى تقريب ما يصل إلى رقمين عشريين وقد يحدث خطأ أيضًا.

حتى لو كانت سالبة فسيتم تقريبها (-1.011 ستكون -1.01 و1.011 ستكون 1.02)

وذلك لتوفير المزيد من الخيارات ل التقريب (أو لأسفل للسلبية) لك استطاع استخدم هذه الوظيفة:

Function RoundUp(Number As Variant, Optional RoundDownIfNegative As Boolean = False)
On Error GoTo err
If Number = 0 Then
err:
    RoundUp = 0
ElseIf RoundDownIfNegative And Number < 0 Then
    RoundUp = -1 * Int(-100 * (-1 * Number)) / -100
Else
    RoundUp = Int(-100 * Number) / -100
End If
If Round(Number, 2) = Number Then RoundUp = Number
End Function

(يستخدم في الوحدة النمطية، إذا لم يكن واضحًا)

فيما يلي طريقة سهلة للتقريب دائمًا إلى الرقم الصحيح التالي في Access 2003:

BillWt = IIf([Weight]-Int([Weight])=0,[Weight],Int([Weight])+1)

على سبيل المثال:

  • [الوزن] = 5.33؛كثافة العمليات ([الوزن]) = 5؛إذن 5.33-5 = 0.33 (<>0)، لذا فإن الإجابة هي BillWt = 5+1 = 6.
  • [الوزن] = 6.000، Int([Weight]) = 6، لذا 6.000-6 = 0، لذا فإن الإجابة هي BillWt = 6.
مرخصة بموجب: CC-BY-SA مع الإسناد
لا تنتمي إلى StackOverflow
scroll top