رجب جاويش

تفضل أخى واذا أردت أى تعديل أخبرنى copy color.rar

أخى الفاضل ارفق الملف الذى يحتوى على البيانات حتى يمكن تتبع عمل الكود

أخى الفاضل فى الكود الأول ( الموجود فى الموديول الأول) غير الرقم 50 الى الرقم 150 فى السطر التالى Const lastrow As Long = 50 ثم احذف الأكواد الأخرى

بعد اذن أخى الحبيب / محمود بعد اذن أخى الحبيب / جمال الفار أخى / عبد الله جرب هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) If Not Application.Intersect(Target, Range("A:A")) Is Nothing Then Application.EnableEvents = False Application.Undo Application.EnableEvents = True End If End Sub حماية العمود الأول.rar

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

أخى الفاضل أرجو توضيح ما تريده أكثر داخل الملف

الأستاذ الفاضل / الخالدي دائما أكوادك تعزف نغمة يصعب على الجميع عزف مثلها بارك الله فيك وكل عام وأنتم بخير

أخى الفاضل من الأفضل أن ترسل أنت ملف توضح فيه ما تريد حتى يتم العمل عليه

ويمكن اختصاره فى سطر واحد Sub ragab() Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2).Select End Sub

أخى الفاضل هذا هو الكود Sub ragab() LR = Cells(Rows.Count, 2).End(xlUp).Row Cells(LR, 2).Select End Sub

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

أختى الفاضلة جزاك الله كل خير على هذه الكلمات الطيبة وكل عام وأنتم بخير

ملحوطة بسيطة فى الكود السابق يفضل حذف الجزء 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 مساويا للصفر

أخى الفاضل / مدريدي عمان شكرا جزيلا أخى الحبيب على الكلمات الطيبة وعلى هذا الدعاء الطيب الذى أسأل الله أن يجزيك مثله أضعافا مضاعفة وكل عام وأنتم بخير

أخى الحبيب / محمود مجهود جبار ونشاط منقطع النظير بارك الله فيك

أخى الفاضل / جروان شكرا جزيلا أخى الحبيب على الكلمات الطيبة وعلى هذه الثقة الغالية وجزاك الله كل خير وكل عام وأنتم بخير

أخى الفاضل / مدريدي عمان يوجد فى الملف المرفق الملف بعد تعديلة وسبب الخطأ فى السطر التالى For Each ws In ThisWorkbook.Worksheets حيث أن هذا السطر يخبر الكود بأن يمر على جميع شيتات الملف لكى يختبر فيها الشروط الموجودة فى السطور التاليه له طبعا يدخل ضمن الشيتات الشيت الذى يتم جلب البيانات اليه وهى الورقة 1 مما يؤدى الى تكرار البيانات وبالتالى لابد من استبعاد هذه الورقة من اختبار الشروط كالاتى جعلت الورقة التى يتم جلب البيانات اليها رقم 3 ثم استبدلت حلقة التكرار السابقة بالحلقة التالية For i = 1 To 2 وهى كما ترى خاصة بالورقة الاولى والثانية فقط study1.rar

أخى الفاضل / يوسف شكرا جزيلا أخى الفاضل وجزاك الله كل خير أخى الحبيب / محمود بارك الله فيك على هذا المجهود ولكن أخى الحبيب حسب طلب الأخ الفاضل / عمرو رحيل يتم استبعاد أى رقم يحتوى على صفر ( فى أى موقع من الرقم ) مثل 1001 و 1020 و 1860 و 1099 و 9880 وهكذا كما يتم استبعاد أى عدد يحتوى على رقمين أو أكثر متشابهين مثل 1213 و 1223 و 8872 و 5654 و هكذا هذا ما فهمته من طلب الأخ الفاضل / عمرو رحيل وعملت الكود على أساسه

أخى الفاضل / عمرو رحيل جرب الكود التالى 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

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

تفضل أخى دفتر النقل.rar

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

أخى الفاضل قمت بعمل ربط لأزرار الترم الأول بالاكواد الخاصة بها وعمل أكواد لأزرار الترم الثانى أيضا وربطها بها ولكن بالنسبة لربط صفحة الرصد بالشيت يوجد اختلاف فى الدرجات بين الصفحتين فكيف يتم الربط مع وجود هذا الاختلاف مرفق الملف بعد التعديل عليه لابداء الرأى بدايه.rar

أخى الفاضل لكى ترفق ملف يجب ضغطة أولا باستخدام برنامج ضغط مثل winrar ثم رفعه للمنتدى

أخى الفاضل جرب الملف المرفق ان شاء الله يكون هو ما تريد آخر خليه.rar