تصفية بشروط خاصة

[عمرو رحيل]

الاخوة الاعزاء

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

المرفق به المطلوب وهو عمل تصفية لعمود بشروط خاصة

وكل عام وانتم بخير

تصفية.rar

[رجب جاويش]

أخى الفاضل / عمرو رحيل

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

Sub ragab()

Application.ScreenUpdating = False

[C2:C9000].ClearContents

For Each cl In [A2:A9000]

R1 = Mid(cl, 1, 1): R2 = Mid(cl, 2, 1): R3 = Mid(cl, 3, 1): R4 = Mid(cl, 4, 1)

If R1 <> 0 And R2 <> 0 And R3 <> 0 And R4 <> 0 Then

If R1 <> R2 And R1 <> R3 And R1 <> R4 And R2 <> R3 And R2 <> R4 And R3 <> R4 Then

MyArr = MyArr & cl & ","

End If

End If

Next

MyArr = Left(MyArr, Len(MyArr) - 1)

For Each c In Split(MyArr, ",")

Cells(Cells(Rows.Count, 3).End(xlUp).Row + 1, 3) = c

Next

Application.ScreenUpdating = True

End Sub

تصفية2.rar

[جمال عبد السميع]

أستاذي ومعلمي الرائع (رجب جاويش ) طبعا لن أستطيع مهما عملت أن أصل لتلك الروعة والجمال في أعمالك ولكن أسمح لتلميذك أن يقدم الحل بالمعادلات بعد أن أستفاد الجميع بوجبتك الدسمة والهدف من تقديمة بالمعادلات ليس كبديل للكود لأن الكود أفضل وأسرع ولكن لأحتمالية تفكير البعض في حلة بالمعادلات وأثراء الموضوع

تصفية 3.rar

[يوسف السيد]

كود رائع بارك الله فيك

[رجب جاويش]

أخى الفاضل / يوسف

شكرا جزيلا أخى الفاضل

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

أخى الحبيب / محمود

بارك الله فيك على هذا المجهود

ولكن أخى الحبيب حسب طلب الأخ الفاضل / عمرو رحيل

يتم استبعاد أى رقم يحتوى على صفر ( فى أى موقع من الرقم )

مثل 1001 و 1020 و 1860 و 1099 و 9880 وهكذا

كما يتم استبعاد أى عدد يحتوى على رقمين أو أكثر متشابهين

مثل 1213 و 1223 و 8872 و 5654 و هكذا

هذا ما فهمته من طلب الأخ الفاضل / عمرو رحيل

وعملت الكود على أساسه

[جمال عبد السميع]

فعلا أستاذي وتم عمل اللازم أعتقد أستاذي الصفر في نهاية الرقم غير مستبعد وفقا لكلامة في المرفق وكذلك عدم تجاور الصفر

كذلك المعادلة الموجودة في العمود المخفي يمكن إضافة لها ماشاء من شروط لتتماشي مع طلبة

تصفية 3.rar

[جمال عبد السميع]

وهذا أستاذي ومعلمي ( رجب جاويش ) المرفق التالي وقد تم حذف جميع الأصفار

تصفية 4.rar

[رجب جاويش]

أخى الحبيب / محمود

مجهود جبار ونشاط منقطع النظير

بارك الله فيك

[جمال عبد السميع]

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

[رجب جاويش]

ملحوطة بسيطة

فى الكود السابق يفضل حذف الجزء R1 <> 0 من السطر التالى

If R1 <> 0 And R2 <> 0 And R3 <> 0 And R4 <> 0 Then

ليصبح السطر كالآتى

If  R2 <> 0 And R3 <> 0 And R4 <> 0 Then

لأنه من غير المنطقى أن يكون R1 مساويا للصفر

[الخالدي]

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

بارك الله فيكم اخي رجب واخي محمود

وهنا كود اخر في حالة كان عدد الارقام في الخلية غير ثابت

Sub AL_KHALEDI()

[C2:C9000].ClearContents

MyArr = 0 & "," & " " & ","

For Each cl In [A2:A9000]

x = cl.Value

For r = 1 To Len(cl)

	 If Len(Application.Substitute(cl, Mid(cl, r, 1), "")) <> Len(cl) - 1 Then

		 x = " "

		 Exit For

	 End If

Next r

MyArr = MyArr & x & ","

Next

MyArr = Join(Filter(Filter(Split(MyArr, ","), 0, 0), " ", 0), ",")

x = UBound(Split(MyArr, ","))

Cells(2, 3).Resize(x).Value = WorksheetFunction.Transpose(Split(MyArr, ","))

End Sub

تصفية.rar

[جمال عبد السميع]

ماشاء الله أستادي ومعلمي ( رجب جاويش ) علي مدي حرص حضرتك علي تصحيح المعلومة وروعة وسلاسة أستاذي الخالدي بارك الله فيكم وشكرا علي المرور الطيب وهذا التشجيع الجميل

[رجب جاويش]

الأستاذ الفاضل / الخالدي

دائما أكوادك تعزف نغمة يصعب على الجميع عزف مثلها

بارك الله فيك

وكل عام وأنتم بخير

[عمرو رحيل]

الاحوة الافاضل

أ/ رجب

أ/ محمود

أ/ الخالدى

اشكركم بشدة على اهتمامكم بالرد وهذا ليس بغريب عليكم

بارك الله فيكم وجعله فى ميزان حسناتكم إن شاء الله .... وكل عام وانتم جميعا بكل خير

[جمال عبد السميع]

شكرا أخي وصديقي عمرو والشكر الأكبر للأساتذه الكبار

[رجب جاويش]

لا شكر على واجب أخى عمرو

وكل عام وأنتم بخير