حل مشكلة تخزين رقم كبير جدا برمجيا

[محمد ايمن]

الاصدقاء الاكارم السلام عليكم و رحمة الله و بركاته

في المرفق كود لتقريب الرقم الى الالف الاقرب برمجيا

المشكلة ان الكود يتوقف عند الرقم 2.147.483.647 و يظهر خطا over flow

ما السبب علما ان جميع المتغيرات من نوع double

المصنف1.rarFetching info...

[lionheart]

Try this instead

Function MyRound(ByVal mainVal As Double, ByVal roundVal As Double) As Double
    Dim h As Double, v As Double
    On Error GoTo ErrSub
    h = roundVal / 2
    If mainVal >= 0 Then
        If (mainVal Mod roundVal) >= h Then
            v = Application.WorksheetFunction.RoundUp(mainVal / roundVal, 0) * roundVal
        Else
            v = Application.WorksheetFunction.RoundDown(mainVal / roundVal, 0) * roundVal
        End If
    End If
    MyRound = v
    Exit Function
ErrSub:
    MsgBox Err.Number & vbCrLf & Err.Description, vbCritical + vbMsgBoxRight
    MyRound = 0
End Function

 

[محمد ايمن]

للاسف اخي الكريم نفس المشكلة

[أبوعيد]

جرب واجعل المتغيرات من نوع Long

[ابو جودي]

السلام عليكم 

هل تقبلون تجربة احد جيرانكم من منتدى الاكسس 

جرب الكود الاتى
 

' This function rounds a given value to the nearest multiple of a specified value.
' It uses Excel's built-in RoundUp and RoundDown functions to perform the rounding.
'
' Parameters:
'   mainVal: The value to be rounded (of type Double).
'   roundVal: The multiple to which mainVal will be rounded (of type Double).
'
' Returns:
'   The rounded value as a Double.
'   If roundVal is zero or an error occurs, the function returns 0.
'
' Error Handling:
'   The function raises an error if roundVal is zero to prevent division by zero.
'   If any other error occurs, a message box displays the error number and description.

Function MyRound(ByVal mainVal As Double, ByVal roundVal As Double) As Double
    Dim h As Double, v As Double
    Dim remainder As Double
    
    On Error GoTo ErrSub
    
    ' Check if roundVal is zero to avoid division by zero error
    If roundVal = 0 Then
        Err.Raise vbObjectError + 9999, "MyRound", "RoundVal cannot be zero."
    End If
    
    ' Calculate half of roundVal
    h = roundVal / 2
    
    ' Calculate the remainder of mainVal divided by roundVal
    remainder = mainVal - Int(mainVal / roundVal) * roundVal
    
    ' Determine whether to round up or down based on the remainder and half of roundVal
    If mainVal >= 0 Then
        If remainder >= h Then
            v = Application.WorksheetFunction.RoundUp(mainVal / roundVal, 0) * roundVal
        Else
            v = Application.WorksheetFunction.RoundDown(mainVal / roundVal, 0) * roundVal
        End If
    End If
    
    ' Return the rounded value
    MyRound = v
    Exit Function
    
ErrSub:
    ' Handle errors and provide a meaningful message
    MsgBox "Error Number: " & Err.Number & vbCrLf & "Description: " & Err.Description, vbCritical + vbMsgBoxRight
    MyRound = 0
End Function

 

وفكرة أخرى تعتمد على العمليات الجسابية بعيدا عن الدوال

Function MyRound(ByVal mainVal As Double, ByVal roundVal As Double) As Double
    Dim roundedValue As Double
    Dim quotient As Double
    
    On Error GoTo ErrHandler
    
    ' Check if roundVal is zero to avoid division by zero error
    If roundVal = 0 Then
        Err.Raise vbObjectError + 9999, "MyRound", "RoundVal cannot be zero."
    End If
    
    ' Calculate the quotient of mainVal divided by roundVal
    quotient = mainVal / roundVal
    
    ' Determine whether to round up or down based on the quotient
    If quotient - Int(quotient) >= 0.5 Then
        roundedValue = Application.WorksheetFunction.RoundUp(quotient, 0) * roundVal
    Else
        roundedValue = Application.WorksheetFunction.RoundDown(quotient, 0) * roundVal
    End If
    
    ' Return the rounded value
    MyRound = roundedValue
    Exit Function

ErrHandler:
    ' Handle errors and provide a meaningful message
    MsgBox "Error Number: " & Err.Number & vbCrLf & "Description: " & Err.Description, vbCritical + vbMsgBoxRight
    MyRound = 0
End Function

 

[محمد ايمن]

  في 29‏/7‏/2024 at 03:38, أبوعيد said:

جرب واجعل المتغيرات من نوع Long

Expand  

اخي الكريم المتغير long لا يخزن اكبر من 2 مليار و 150 الف تقريبا

 

[محمد ايمن]

اخي @ابو جودي تحية طيبة 

جزاك الله كل خير ولكن التقريب يتم مع الارقام الموجبة فقط اما الارقام السالبة يتم التقريب بشكل خاطئ

تم الوصول للحل و الحمدلله و الشكر للجميع

Public Function MyRound(ByVal MainVal As Double, ByVal RoundVal As Double) As Double
Dim Oldrnd As Double, X2 As Double, Newrnd As Double, Var1 As Double
On Error GoTo ErrSub

Var1 = RoundVal \ 2
X2 = Application.WorksheetFunction.RoundDown(MainVal / RoundVal, 0)

Newrnd = X2 * RoundVal
Oldrnd = MainVal - Newrnd

Select Case Oldrnd
Case Is >= 0
    Select Case Oldrnd
        Case Is >= Var1
            MyRound = Newrnd + RoundVal
        Case Is < Var1
            MyRound = Newrnd
    End Select
Case Is < 0
Var1 = Var1 * -1
    Select Case Oldrnd
        Case Is <= Var1
            MyRound = Newrnd - RoundVal
        Case Is > Var1
            MyRound = Newrnd
    End Select
End Select

ErrSub:
If Err.number <> 0 Then
'MsgBox Err.number & vbCrLf & Err.Description, vbCritical + vbMsgBoxRight
MyRound = 0
Exit Function
End If

End Function

 

[ابو جودي]

  في 31‏/7‏/2024 at 18:31, محمد ايمن said:

جزاك الله كل خير

Expand  

واياكم اخى الحبيب 

  في 31‏/7‏/2024 at 18:31, محمد ايمن said:

ولكن التقريب يتم مع الارقام الموجبة فقط اما الارقام السالبة يتم التقريب بشكل خاطئ

Expand  

والله انا كنت مستعجل وفت ما كتبت الاكواد اعتذر 

  في 31‏/7‏/2024 at 18:31, محمد ايمن said:

تم الوصول للحل و الحمدلله

Expand  

الحمد لله الذى تتم بنعمته الصالحات 

 

[AbuuAhmed]

جرب محاولتي
ولكن عملتها "عمياني"، ما أدري بالضبط المطلوب من الدالة ولكني أجريت كل العمليات على صفحة اكسل، اختبرها وخبرني حتى ولو وجدت حل آخر، ربما نستطيع تطبيق الفكرة على دوال كثيرة نتائجها تتجاوز نطاق متغيرات الـ vba.

المصنف_03.xlsmFetching info...

[AbuuAhmed]

حل آخر:
بدل هذا السطر:
 

X2 = MainVal \ RoundVal

بهذا السطر:
 

X2 = Fix(MainVal / RoundVal)

 

[AbuuAhmed]

فقط قبل نصف ساعة فهمت موضوعك، دائما عند تقديم مثال يجب تقديم الحل/الناتج المطلوب، بمعني تقول هذه المعادلة يفترض أن يكون جوابها هكذا.
اختصرت لك كل هالمشقة والأكواد بسطر واحد فقط، آمل التجربة والعودة لنا بملاحظاتك.
وبعد المزيد من التجارب أضفت سطر آخر 🙂 
 

Function myRound(MainVal As Double, RoundVal As Double) As Double
    Dim Adj As Double
    Adj = (0.1 / RoundVal) * Sgn(MainVal)
    
    myRound = Round(MainVal / RoundVal + Adj) * RoundVal
End Function

وهذا سطر للاحتراز يمكن إضافته بداية الدالة عند الرغبة:
 

    If RoundVal < 10 Or RoundVal Mod 10 <> 0 Then Exit Function

 

تم تعديل أغسطس 1, 2024 بواسطه AbuuAhmed