دوال التقريب

[AbuuAhmed]

ألم يطلب السائل أن يجبر النصف إلى واحد صحيح؟ أين تحقق هذا في الاختيار والثاني!!

 

وبدل أن تناقش الأمر بشكل علمي تكلمني عن متلازمة أفضل إجابة!! وعن التوسع!!

 

بدون التوسع لم يفي أحدكم بطلبه والرجل نفسه ما يدري وين الإجابة المناسبة واعتمد على القرعة!.

[ابوخليل]

10 دقائق مضت, AbuuAhmed said:

ألم يطلب السائل أن يجبر النصف إلى واحد صحيح؟ أين تحقق هذا في الاختيار والثاني!!

 

نعم هي تجبر ، وقد ادرجت دالة المهندس @Eng.Qassim  البارحة في عمل لواحد من الاخوة وكانت النتيجة ممتازة

على كل حال وقصرا لتشعب النقاش كتبت هذا الموضوع للسبب نفسه

[Foksh]

2 ساعات مضت, AbuuAhmed said:

أشكركم أستاد @Foksh على اهتمامكم، حاول تعدل على ملف الإكسل بإزالة دالتك القديم واستبدالها بالحديثة واطلعنا على المقارنة.
أنا عملت دالة vba أخرى باستخدام دوال الإكسل ولو كنت أعرف عنها قبل دوالي الأربع للأكسس لما أجهدت نفسي في تصميمها.

بما ااني حالياً اتابع من الجوال ، لنجرب هذه الفكرة :- 

Public Function RoundCustom(inputValue As Double) As Double
    Dim absValue As Double
    absValue = Abs(inputValue)
    RoundCustom = Sgn(inputValue) * (Int(absValue) + IIf(absValue - Int(absValue) <= 0.5, 0.5, 1))
End Function

والاستدعاء سيكون في الخلية B1 مثلاً :-

=RoundCustom(A1)

 

لست ضليعاً في اكسل لهذا الحد ، ولكن هي فكرة وانتظر تجربتها 😅 من طرفكم أستاذنا الكريم.

[AbuuAhmed]

دالة أخيرة في حال أن السائل لا يريد جبر النصف إلى واحد، وهي تعتمد على دالة الإكسل:

Function vbCEILING(ByVal Arg1 As Double, ByVal Arg2 As Double) As Double
    'AbuuAhmed
    Arg2 = Abs(Arg2) * Sgn(Arg1)    'اختياري
    vbCEILING = WorksheetFunction.Ceiling(Arg1, Arg2)
End Function

[AbuuAhmed]

تم استبدال دالة @Foksh 
وتم إضافة دالة جديدة لـ @AbuuAhmed
تم تلوين النتائج الخاطئة بالأصفر.

CustomCeiling_02.xlsm

[Foksh]

وبهذا التعديل :

 

Public Function RoundToNearestHalf(ByVal inputValue As Double) As Double
    Dim absValue As Double
    absValue = Abs(inputValue)
    If absValue - Int(absValue) = 0 Then
        RoundToNearestHalf = inputValue
    ElseIf absValue - Int(absValue) < 0.5 Then
        RoundToNearestHalf = Sgn(inputValue) * (Int(absValue) + 0.5)
    Else
        RoundToNearestHalf = Sgn(inputValue) * (Int(absValue) + 1)
    End If
End Function

 

[ابو جودي]

10 ساعات مضت, AbuuAhmed said:

أول: أن أكثركم ذهب لمعالجة الكسر إذا كان أصغر من نصف أو (أكبر أو يساوي نصف) ولكن غفل عن الكسر إذا كان صفرا والذي لا يحتاج إلى معالجة.
الآخر: عدم اختبار دوالكم مع الأرقام السالبة، وهذه تحتاج إلى مزيد من العناية والحرص ومعرفة تامة بالتعامل مع دالتي int و fix أو trunc في لغات أخرى.

كل االشكر والتقدير استاذى الجليل و معلمى القدير فعلا لم انتبه او اخذ فى الاعتبار ما تفضلتم به
ولكن على كل حال 

هل هذا الكود استاذى الجليل يفى بالغرض ويأخذ فى الاعتبار كل ما تفضلتم به ام هناك شئ لم انتبه اليه ؟

Public Function CustomRound(ByVal numValue As Double) As String
    On Error GoTo ErrorHandler

    Dim wholePart As Double
    Dim fractionalPart As Double
    
    ' Extract the whole part and the fractional part of the number using Fix for accurate handling of negative numbers
    wholePart = Fix(numValue)
    fractionalPart = numValue - wholePart
    
    ' Custom rounding logic
    If fractionalPart = 0 Then
        CustomRound = wholePart ' No rounding needed for whole numbers
    ElseIf fractionalPart = 0.5 Or fractionalPart = -0.5 Then
        CustomRound = numValue ' Keep the number as it is for ±0.5
    ElseIf numValue > 0 Then
        If fractionalPart < 0.5 Then
            CustomRound = wholePart + 0.5 ' Round to 0.5 for positive numbers
        Else
            CustomRound = wholePart + 1 ' Round up to the next whole number for positive numbers
        End If
    Else
        ' For negative numbers, adjust rounding
        If fractionalPart <= -0.5 Then
            CustomRound = wholePart - 1 ' Round down to the next lower whole number
        Else
            CustomRound = wholePart - 0.5 ' Round to -0.5 for negative numbers
        End If
    End If
    
    ' Format the result to display two decimal places
    CustomRound = Format(CustomRound, "0.00")
    
    Exit Function

ErrorHandler:
    MsgBox "Error in CustomRound function: " & Err.Description, vbCritical, "Error"
    CustomRound = "0.00" ' Return 0.00 in case of an error
End Function

 

[AbuuAhmed]

آخر تحديث
الأستاذ @Foksh تم التعديل على أحد السطور حتى لا ترجع لي بطلب جديد.
الأكواد في الملف.
أرجو حذف المرفقات السابقة، (ملفات الإكسل فقط مع الإبقاء على المشاركات والصور).
أرجو قفل هذا الموضوع.

CustomCeiling_03.xlsm

تم تعديل منذ 12 ساعات بواسطه AbuuAhmed