دوال التقريب

[عبد الله-بلال]

السلام عليكم إخواني أريد دالة تقرب للأعلى في أكسس في حقل محسوب فمثلا : ما دون 0.5 تعطيني نصف و ما فوق 0.5 يعطيني 1 و جزاكم الله كل الخير

[ابوخليل]

في وحدة نمطية عامة الصق هذه الدالة

Public Function RoundNmber(Rou As Double) As Double
    Dim i As Double
    i = Val(Rou)
    If i < CInt(i) Then
        i = CInt(i)
    ElseIf (i - CInt(i)) > 0 Then
        i = CInt(i) + 0.5
    End If
    RoundNmber = i
End Function

تناديها من اي مكان في الاستعلام او النموذج او التقرير'

 =RoundNmber([yourText])

 

[عبد الله-بلال]

أبو خليل السلام عليكم و رحمة الله تعالى و بركاته و جزاكم الله خيرا على هذا الرد السريع .  تحياتي

[Eng.Qassim]

مشاركة مع استاذي @ابوخليل

Public Function RoundNmber(Rou As Double) As Double
    If Rou - Int(Rou) < 0.5 Then
        RoundNmber = Int(Rou) + 0.5
    Else
        RoundNmber = Int(Rou) + 1
    End If
End Function

 

[Foksh]

مشاركة مع الاساتذة ومعلمنا الفاضل ..

Private Sub Text0_AfterUpdate()
Text0 = Int(Text0) + IIf(Text0 - Int(Text0) <= 0.5, 0.5, 1)
End Sub

وهذه الفكرة من خلا الاستعلام :-

RoundedValue: Int([اسم الحقل]) + IIf([اسم الحقل] - Int([اسم الحقل]) <= 0.5, 0.5, 1)

 

تم تعديل الإثنين at 09:57 بواسطه Foksh
اضافة فكرة من خلال الاستعلام

[عبد الله-بلال]

السلام عليكم يا أساتذتي الأعزاء جزاكم الله كل الخير . عندي استفسار لأبو خليل : لقد جربت الدالة هي تعمل مع 0.5 فقط بمعنى إذا كان الرقم مثلا 8.25 تعطينا 9 و هي في الواجب تعطينا 8.50 يعني كل ما فوق 0.50 يكون صحيحا و أما دون 0.50 تعطينا بالخطأ : فمثلا : 7.75 تعطي 8 و هذا صحيح و أما 7.26 تعطينا كذلك 8 و هذا خطأ .فالواجب تعطينا 7.50 . أرجو أن أكون وفقت في إبراز الفكرة و شكرا

[عبد الله-بلال]

السلام عليكم إخواني 

أريد المشاركة مع أستاذي الفاضل Eng.Qassim 

لقد أضفت إضافة عل الدلة التي استفدنا منها جزاكم الله خيرا فأوفت بالغرض و الحمد لله و هي كما يلي :

Public Function RoundNmber(Rou As Double) As Double
    If Rou - Int(Rou) = 0 Then
        RoundNmber = Int(Rou)
        Else
        If Rou - Int(Rou) <= 0.5 Then
           RoundNmber = Int(Rou) + 0.5
        Else
        
        RoundNmber = Int(Rou) + 1
    End If
    End If
End Function

جزاكم الله كل الخير و شكرا

[ابوخليل]

1 ساعه مضت, عبد الله-بلال said:

لقد أضفت إضافة عل الدلة التي استفدنا منها جزاكم الله خيرا فأوفت بالغرض و الحمد لله 

الحمد لله

[Eng.Qassim]

الحمد لله 

 

[AbuuAhmed]

عملت دالتين أحدهما مختصرة ولكنها فشلت في تقريب النصف، لذا استبعدتها.
الدالة الأطول والأدق:
 

Function myRound(ByVal Expression As Double) As Double
  Dim SgnVal As Integer
  Dim frac As Double
  
  SgnVal = Sgn(Expression)
  Expression = Abs(Expression)
  frac = Expression - Fix(Expression)
  
  If frac >= 0.5 Then frac = 1
  If frac > 0 And frac < 0.5 Then frac = 0.5
  
  myRound = (Fix(Expression) + frac) * SgnVal
End Function

 

 

تم تعديل بالامس في 07:08 بواسطه AbuuAhmed

[ابوخليل]

1 ساعه مضت, AbuuAhmed said:

عملت دالتين أحدهما مختصرة ولكنها فشلت في تقريب النصف، لذا استبعدتها.
الدالة الأطول والأدق:

 

 يا هلا ابو احمد  .. عودا حميدا 

من طول الغيبات جاب الغنايم 

[AbuuAhmed]

1 ساعه مضت, ابوخليل said:

ا هلا ابو احمد  .. عودا حميدا 

من طول الغيبات جاب الغنايم 

يا هلا بيك وشكرا لك.

وجدت في جهازي دالة بنفس اسم دالة الإكسل وأداؤها أفضل من دالة الإكسل حيث في الأرقام السالبة لا يحتاج أن يكون الكسر (Factor) سالب لتعطي نتائج صحيحة.
الدالة ليست من عملي، وزدت بداية اسمها حرفين vb لتمييزها عن دالة الإكسل.
 

Public Function vbCeiling(ByVal X As Double, Optional ByVal Factor As Double = 1) As Double
    ' X is the value you want to round
    ' is the multiple to which you want to round
    vbCeiling = (Int(X / Factor) - (X / Factor - Int(X / Factor) > 0)) * Factor
End Function

لهذا الموضوع تكون قيم Factor نصف أي 0.5
جربوها.

[ابو جودي]

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

يا هلا بيك وشكرا لك.

وجدت في جهازي دالة بنفس اسم دالة الإكسل وأداؤها أفضل من دالة الإكسل حيث في الأرقام السالبة لا يحتاج أن يكون الكسر (Factor) سالب لتعطي نتائج صحيحة.
الدالة ليست من عملي، وزدت بداية اسمها حرفين vb لتمييزها عن دالة الإكسل.
 

Public Function vbCeiling(ByVal X As Double, Optional ByVal Factor As Double = 1) As Double
    ' X is the value you want to round
    ' is the multiple to which you want to round
    vbCeiling = (Int(X / Factor) - (X / Factor - Int(X / Factor) > 0)) * Factor
End Function

لهذا الموضوع تكون قيم Factor نصف أي 0.5
جربوها.

انا اللى كنت كاتب الكود ده 👆

وتجد مزيد من الشرح فى هذا الموضوع 

 

[ابو جودي]

 طيب ومشاركة مع اساتذتى العظماء هذه فكرتى المتواضعة
 

' ---------------------------------
' Custom Rounding Function: Rounds a number based on fractional parts
' Parameters:
'   - numValue (Double): The number to round.
' Returns:
'   - (Double): The custom rounded value.
' ---------------------------------
Public Function CustomRound(ByVal numValue As Double) As Double
    On Error GoTo ErrorHandler

    Dim wholePart As Double
    Dim fractionalPart As Double
    
    ' Extract the whole part and the fractional part of the number
    wholePart = Int(numValue)
    fractionalPart = numValue - wholePart
    
    ' Custom rounding logic
    If fractionalPart < 0.5 Then
        CustomRound = wholePart + 0.5 ' Round to 0.5
    Else
        CustomRound = wholePart + 1 ' Round to the next whole number
    End If

    Exit Function

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

 

CustomRound.mdb

[AbuuAhmed]

كنت أبحث عن موضوع سابق لي لعمل بعض الدوال شبيهة للإكسل ووجدتها بعد وقت طويل.

استخدمت أحد الملفات وزدت عليه دالتك، أرجو الاطلاع.

CeilingFunction4Access_04.xlsm

[ابو جودي]

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

كنت أبحث عن موضوع سابق لي لعمل بعض الدوال شبيهة للإكسل ووجدتها بعد وقت طويل.

لكن دالة CEILING اساسا موجودة بالاكسل من ضمن الدوال المضمنه به ولم تكن تحتاج الى كتابة اى اكواد

[AbuuAhmed]

مشاركتي الأخيرة في هذا الموضوع
ملخص مقارنة لجميع المشاركات في ملف إكسل وصورة.

اقتباس

لكن دالة CEILING اساسا موجودة بالاكسل من ضمن الدوال المضمنه به ولم تكن تحتاج الى كتابة اى اكواد

الدالة المذكورة ومثيلاتها الثلاث صممت للأكسس مع تطابق تام مع دوال الإكسل بقدر الاستطاعة، وملف الإكسل ما هو إلا وسيلة للمقارنة فقط.

موفقين جميعا، أنا لم أغادر أوفيسنا، ومتواجد في منتدى الإكسل لمن يريد متابعتي.

CustomCeiling_01.xlsm