بالكود تحويل أرقام عشرية صغيرة إلى صفرية

[أبو أنس حاجب]

السلام عليكم ورحمة الله وبركاته

أساتذتي الفضلاء حفظكم الله

في العمود L ارصدة منها صفرية وهي المقصودة هنا أرجو ملاحظة أن بعض الخلايا الصفرية وهي ملونة هنا باللون الأصفر تحتوي على أرقام عشرية صغيرة جداً المطلوب كود يقوم بتحويلها إلى قيم صفرية تشبه مثيلاتها من القيم الصفرية المطلقة على أن يغطي عمل الكود حتى السطر ستون ألف

تقبلوا خالص الشكر والتقدير

أبو أنس

نسخ من Suppliers2012.rar

[الـعيدروس]

السلام عيكم

Sub L_ali()

Dim r As Range

For Each r In Range("L6:L6500")

If r - Int(r) > 0 And r.Value <> Empty Then

r.Value = Ali_In(r.Value)

End If

Next

End Sub

Function Ali_In(Val_A As Double) As Double

   Dim ali As Long

   Dim adad As Double

   ali = Int(Val_A)

   adad = Val_A - ali

   If adad < 0.5 Then

	  Ali_In = ali

   Else

	  Ali_In = ali + 1

   End If

End Function

[أبو أنس حاجب]

السلام عليكم ورحمة الله وبركاته

أستاذي وسيدي الفاضل عباد (أبا نصار) حفظكم الله

جزاك الله كل خير وبارك بك وفيك للوهلة الأولى فالكود يحقق الغرض منه.

نور بصرك ربي وبصيرتك بنور الأيمان

أبو أنس ناصر حاجب

[أبو أنس حاجب]

السلام عليكم ورحمة الله وبركاته

أستاذي وسيدي الفاضل العيدروس(أبا نصار) حفظكم الله

بعد تجربة الكود لاحظت أن الأجمالي في الأعلى (داخل مربع النص) يتغير وهو مالا أريده (يجب أن لا يتغير).

رغم أنني غيرت في الكود القيمة الشرطية إلى 0.0000005 مع ذلك لازالت المشكلة.

تقبل فائق التقدير والشكر والأحترام

أبو أنس ناصر حاجب

[أبو أنس حاجب]

السلام عليكم ورحمة الله وبركاته

للرفع رفع الله قدركم

[بن علية حاجي]

السلام عليكم ورحمة الله

أخي الكريم أبو أنس، نتيجة المربع بالأعلى تتغير لا محالة (بالأجزاء العشرية) لأنك تقوم باستبدال بعض القيم القريبة من الصفر بالعدد 0 وهذا يؤثر قليلا على المجموع في هذا المربع... قمت بتغيير طفيف على كود أخي الكريم أبو نصار وكانت النتيجة تختلف في الجزء العشري (العدد بعد الفاصلة) للمجموع : المجموع قبل الاستبدال كان جزؤه العشري 81 والمجموع بعد الاستبدال أصبح جزؤه العشري 91... أعتقد أن النتيجة متقاربة جدا ومقبولة...

والكود بعد التغيير هو:

Sub L_ali()

Dim t As Range

Application.ScreenUpdating = False

For Each t In Range("L6:L60000")

If Abs(Int(t)) <= 1 And t.Value <> Empty Then

t.Value = 0

End If

Next

Application.ScreenUpdating = True

End Sub

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

أرجو أني وفقت في مقاربة الحل...

أخوك بن علية

تم تعديل أكتوبر 6, 2012 بواسطه بن علية حاجي

[أبو أنس حاجب]

السلام عليكم ورحمة الله وبركاته

أستاذي وسيدي الفاضل بن علية حاجي حفظكم الله

أشكر لك التفضل والتكرم بالرد عليّ جزاك الله من الخير حتى ترضى وزيادة وأسعد لك أيامك وحياتك وحفظ لك أهلك وذريتك من بعدك إلى يوم الدين.

سبحان الله حدث أنني قبل أن ترسل لي الأجابة فكرت بأنك من أحتاجه للرد علىّ ولكن قلت في نفسي بأنك منشغل أكثر بالرد على المشاركات الخاصة بالمعادلات المعقدة التي أنت بفضل من الله بارع بها.

ولكن حدث ما أثلج صدري كرماً من عند الله ورديت أنت عليّ

بارك الله بك وفيك

تأخرت نسبياً في الرد عليك حتى أجرب على الملف الأصلي لانه مرتبط بكود آخر أيضاً

ولقد عدلت في السطر التالي

If Abs(Int(t)) <= 1 And t.Value <> Empty Then

كالآتي:

If Abs(Int(t)) <= 0.005 And t.Value <> Empty Then

كي أحاول حل مشكلة الفرق وضبط معي.

أبو أنس ناصر حاجب