الدالة الاولي لم تكن أيضا مجهزة للسالب
فقمت بتعديلها سريعا و مرفق مثال لتطبيقها
فأرجو التجربة
مع ملاحظة أن التقريب للرقم كله و ليس للكسر فقط
و هذا لن يحدث فرقا فى التقريب الي 0.25 أو 0.5 أو 1
و لكن سيحدث فرق مثلا اذا قربنا الي درجة 0.35
فسيكون للرقم الصحيح تأثير فى التقريب
أرجو التجربة و اخباري بالنتيجة و هل أدت الغرض أم لا و هل أداؤها سليم أم لا لأعدلها
Function ROUNDTO(MYNO As Double, MyFraction As Double)
' to round up or down with a certain value
Dim MYBASE As Double, MYREM As Double
If Abs(Round(MyFraction, 2)) <= 0 Then
ROUNDTO = MYNO
Exit Function
End If
Dim neg As Boolean
neg = False
If MYNO < 0 Then neg = True
MYNO = Abs(MYNO * 100)
MyFraction = MyFraction * 100
MYREM = MYNO Mod MyFraction
'MsgBox "rem : " & MYREM
MYBASE = MYNO - MYREM
'MsgBox "Base : " & MYBASE
If MYREM > 0 Then
If MYREM > MyFraction / 2 Then
ROUNDTO = MYBASE + MyFraction
Else
ROUNDTO = MYBASE
End If
Else
ROUNDTO = MYNO
End If
ROUNDTO = ROUNDTO / 100
If neg = True Then ROUNDTO = -ROUNDTO
End Function