أفضل إجابة ياسر خليل أبو البراء قام بنشر مايو 30, 2015 أفضل إجابة قام بنشر مايو 30, 2015 إخواني الكرام في المنتدى الغالي أقدم لكم اليوم موضوع ليس بالجديد ولكنه جد مفيد (جد .. يعني جداً أوك يا جدو) ..أقصد مفيد جداً الموضوع يتمحور ويتمركز حول معرفة الأرقام المفقودة أو الأرقام الناقصة في سلسلة أرقام .. إليكم الكود الأول المؤدي للغرض (هنا يشترط ترتيب الأرقام) ، مع شرح تفصيلي لأسطر الكود لتتمكن من التعديل عليه Sub MissingNumber_NumbersSorted() 'يقوم الكود بإظهار الأرقام الناقصة في تسلسل معين للأرقام ويشترط ترتيب الأرقام '------------------------------------------------------------------------- Dim SH As Worksheet Dim LR As Long Dim Text As String Dim I As Long, X As Long, XX As Long '[Sheet1] تخصيص المتغير ليساوي ورقة العمل المسماة Set SH = Sheets("Sheet1") 'تحديد آخر صف به بيانات في العمود الأول LR = SH.Cells(SH.Rows.Count, 1).End(xlUp).Row 'حلقة تكرارية بداية من الصف الخامس وحتى آخر صف به بيانات في العمود الأول For I = 5 To LR 'يساوي الفرق بين قيمة الخلية التالية وقيمة الخلية الحالية في الصف المحدد [X] المتغير X = Val(SH.Range("A" & I + 1)) - Val(SH.Range("A" & I)) '[X] استخدام الجملة الشرطية لناتج المتغير Select Case X 'إذا كان الفرق بين قيمة الخليتين أكبر من 1 يتم تنفيذ الحلقة التكرارية ما بين السطرين Case Is > 1 'حلقة تكرارية لتخزين الأرقام الناقصة For XX = 2 To X 'يساوي المتغير نفسه مع قيمة الخلية الحالية مضاف إليها قيمة المتغير في الحلقة التكرارية ناقص واحد ثم سطر جديد[Text]المتغير المسمى 'مثال لفهم هذا السطر '------------------- 'توجد القيمة 50012 [A15] توجد القيمة 50009 وفي الخلية [A14] في الخلية 'بما أن الفرق بين الخليتين يساوي 3 إذاً سيتم تنفيذ الحلقة التكرارية 'بداية الحلقة التكرارية 2 حيث أن رقم 2 هو أول رقم أكبر من واحد ، وفي مثالنا نهاية الحلقة التكرارية تساوي 3 'المتغير المفترض تخزين الأرقام الناقصة فيه عبارة عن سلسلة نصية فيتم إضافة النصوص التي سبق استخراجها ثم إضافة النصوص الجديدة 'الأرقام الناقصة تساوي قيمة الخلية الحالية 50009 في المثال مضافاً إليها قيمة الحلقة التكرارية والتي هنا تساوي 2 في بداية الحلقة التكرارية ليصبح الناتج 50011 ثم ناقص واحد لتحصل على أول رقم ناقص ألا وهو 5010 'يساوي 3 لتحصل في النهاية على الرقم التالي الناقص ألا وهو 5011[XX]مع الانتقال في الحلقة التكرارية يصبح المتغير Text = Text & Val(SH.Range("A" & I)) + XX - 1 & vbCrLf Next End Select Next 'رسالة لإظهار الأرقام الناقصة MsgBox Text, vbMsgBoxRtlReading End Sub وإليكم الكود الثاني وهو أقوى في أنه لا يشترط ترتيب الأرقام Sub MissingNumbers_YK_A() 'يقوم الكود باستخراج الأرقام الناقصة من سلسلة من الأرقام ولا يشترط ترتيب الأرقام '---------------------------------------------------------------------------- Dim InputRange As Range, OutputRange As Range, ValueFound As Range Dim LowerVal As Single, UpperVal As Single, Count_I As Single, Count_J As Single Dim NumRows As Long, NumColumns As Long Dim Horizontal As Boolean On Error GoTo ErrorHandler 'النطاق الذي يحتوي سلسلة الأرقام المراد استخراج الأرقام الناقصة منها Set InputRange = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) LowerVal = WorksheetFunction.Min(InputRange) UpperVal = WorksheetFunction.Max(InputRange) Horizontal = False 'بداية النطاق الذي سيتم استخراج النتائج به Set OutputRange = Range("E2") NumRows = OutputRange.Rows.Count NumColumns = OutputRange.Columns.Count Application.ScreenUpdating = False If NumRows < NumColumns Then Horizontal = True NumRows = 1 Else NumColumns = 1 End If Count_J = 1 For Count_I = LowerVal To UpperVal Set ValueFound = InputRange.Find(Count_I, LookIn:=xlValues, LookAt:=xlWhole) If ValueFound Is Nothing Then If Horizontal Then OutputRange.Cells(NumRows, Count_J).Value = Count_I Count_J = Count_J + 1 Else OutputRange.Cells(Count_J, NumColumns).Value = Count_I Count_J = Count_J + 1 End If End If Next Count_I Application.ScreenUpdating = True Exit Sub ErrorHandler: End Sub كما تمت إضافة حل بمعادلات الصفيف لتؤدي نفس الغرض وإليكم أيضاً كود رائع للأخ الحبيب سليم حاصبيا مع شرح للأسطر ولا يشترط الترتيب للأرقام أيضاً Sub MissingNumbers_SALIM() 'يقوم الكود باستخراج الأرقام الناقصة في سلسلة أرقام ولا يشترط الترتيب '------------------------------------------------------------------ 'تعريف المتغيرات Dim Dico, D Dim C As Range, Rng As Range Dim B As Long, I As Long Dim MinVal As Double, MaxVal As Double 'النطاق المراد استخراج الأرقام الناقصة منه Set Rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'سطر لايجاد أقل قيمة رقمية في النطاق MinVal = Application.WorksheetFunction.Min(Rng) 'سطر لايجاد أكبر قيمة رقمية في النطاق MaxVal = Application.WorksheetFunction.Max(Rng) 'مسح محتويات النطاق الذي سيتم استخراج النتائج به Range("G2", Range("G2").End(xlDown)).ClearContents 'إنشاء متغير من النوع كائن لتخزين الأرقام الناقصة به Set Dico = CreateObject("Scripting.Dictionary") 'حلقة تكرارية لكل الأرقام المسلسلة For I = 1 To (MaxVal - MinVal + 1) 'تعتمد هذه الأسطر على إضافة الرقم الناقص إلى الكائن المخصص لذلك If Application.WorksheetFunction.CountIf(Rng, MinVal + I - 1) = Then If Not Dico.Exists(MinVal + I - 1) Then Dico.Add (MinVal + I - 1), (MinVal + I - 1) End If Next I 'رقم صف البداية للنتائج في العمود السابع B = 2 'حلقة تكرارية لوضع القيم التي تم تخزينها في النطاق المحدد For Each D In Dico.items Range("G" & B) = D B = B + 1 Next D End Sub وعشان عيون أحبابي إليكم الكود الرابع وهو أفضل الأكواد من حيث أنه لا يشترط ترتيب الأرقام وأسطر الكود سهلة الفهم وسهلة التعامل معها Sub MissingNumbers_YK_B() 'يقوم الكود باستخراج الأرقام الناقصة في تسلسل للأرقام ولا يشترط الترتيب '------------------------------------------------------------------- 'تعريف المتغيرات Dim InputRange As Range Dim X As Long, lRow As Long 'تعيين النطاق الذي سيحتوي على سلسلة الأرقام المراد استخراج الأرقام الناقصة منها Set InputRange = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'مسح محتويات النطاق الذي سيتم استخراج النتائج به Range("I2:I1000").ClearContents 'حلقة تكرارية من أقل قيمة بالنطاق لأكبر قيمة بالنطاق For X = WorksheetFunction.Min(InputRange) To WorksheetFunction.Max(InputRange) 'استخدام دالة البحث فإذا كانت القيمة المراد البحث عنها غير موجودة يعطي خطأ 'وبناءً على الخطأ يتم تنفيذ السطر التالي If IsError(Application.Match(X, InputRange, )) Then '[I] الرقم 2 هو رقم صف البداية في العمود '[I] يتم وضع الرقم الناقص في الخلية في الصف المحدد في العمود Cells(lRow + 2, "I") = X 'زيادة المتغير بمقدار واحد للانتقال لصف جديد لإدراج الأرقام الناقصة lRow = lRow + 1 End If Next X End Sub أترككم مع الملف المرفق ...للاستفادة بشكل عملي بالكود كان معكم أخوكم ياسر خليل أبو البراء YK (الموضوع مهدى للأخ الحبيب والأستاذ الكبير أسامة البراوي OB ومهدى للأخ الفاضل نايف - م) حمل الملف من هنا تقبلوا تحياتي 9
محمد حسن المحمد قام بنشر مايو 30, 2015 قام بنشر مايو 30, 2015 جزاكم الله خيراً... روح الدعابة ...والجد في العمل ...والنتائج الصحيحة إن الكلمات لتعجز عن تصوير مشاعر الإعجاب بارك الله لك وبك وعليك أبا البراء الغالي.. 1
سليم حاصبيا قام بنشر مايو 30, 2015 قام بنشر مايو 30, 2015 اكثر من رائع اخي ياسر وما رأيك بعمل نفس الشيء بواسطة المعادلات ارقام ناقصة.rar 2
ياسر خليل أبو البراء قام بنشر مايو 30, 2015 الكاتب قام بنشر مايو 30, 2015 الأخوة الكرام مشكور على مرروكم العطر الأخ الغالي أبو يوسف جزيت خيراً على مرورك العطر ومشكور على كلماتك الرقراقة العذبة التي تسعد القلوب ..لا حرمنا الله منك الأخ الحبيب سليم دائماً ما تتحفنا بهداياك القيمة الأخ الفاضل نايف لما لا تقوم بترتيب الأرقام ثم تنفيذ الكود لتحصل على المطلوب
سليم حاصبيا قام بنشر مايو 30, 2015 قام بنشر مايو 30, 2015 الاخ نايف تم العمل كما تريد serie non reguliee.rar 2
نايف - م قام بنشر مايو 30, 2015 قام بنشر مايو 30, 2015 أستاذي الكريم ياسر يمكن ترتيب الأرقام ثم تنفيذ الكود لكن الترتيب يكون تصاعدي في عمود آخر يحوي الباركود للدواء الأخ الكريم سليم سأقوم بالتجريب و لأخبارك شكرا لك
صلاح الصغير قام بنشر مايو 30, 2015 قام بنشر مايو 30, 2015 ا / سليم ا / ياسر اكثر من رائع بارك الله فيكم
سليم حاصبيا قام بنشر مايو 30, 2015 قام بنشر مايو 30, 2015 اخي نايف اليك ما تريد بواسطة الكود,فليكن ذلك (هو انا يهمني -على رأي الفنان عادل امام) انظر الى الصفحة Mydata serie non reguliee (vba).rar 1
Yasser Fathi Albanna قام بنشر مايو 30, 2015 قام بنشر مايو 30, 2015 سلمت يمينك أخى الحبيب / ياسر خليل قمة الروعة تقبل تحياتى وتقديرى
ياسر خليل أبو البراء قام بنشر مايو 30, 2015 الكاتب قام بنشر مايو 30, 2015 أخي الحبيب سليم بارك الله فيك جزاك الله كل خير الأخ الكريم نايف والأخوة الكرام تم إعادة رفع الملف مرة أخرى في المشاركة الأولى بعد التعديل عليها نظراً لأنني أضفت حل بمعادلة صفيف ليناسب طلب الأخ نايف من حيث أن الأرقام غير مرتبة ..وبدون أعمدة مساعدة يا مستر سليم الأخ الحبيب ياسر فتحي / الأخ الغالي الزباري / الأخ الكريم صلاح الصغير مشكور على مرروكم العطر بالموضوع ، بارك الله فيكم تقبلوا تحياتي
ياسر خليل أبو البراء قام بنشر مايو 30, 2015 الكاتب قام بنشر مايو 30, 2015 الأخ عبد العزيز البسكري جزيت خيراً على مرورك العطر نداء إلى أخي الحبيب سليم يرجى تطبيق الكود الخاص بك على الملف الأصلي في النطاق A5:A وحتى آخر صف ..شوف النتائج ...............الكود بيحصل إنه بيهنج ولابد من الضغط على Ctrl + End لينتهي عمل الكود !! ويعطي نتائج أكثرمن اللازم
سليم حاصبيا قام بنشر مايو 30, 2015 قام بنشر مايو 30, 2015 الكود عندي اشتغل بشكل طبيعي جداً و ليس هناك من حلقات تكلرارية لا نهائية عندي الاوفيس 2010 و لا اعلم اذا كانت هناك مشكلة بالنسبة للكود في باقي الاصدارات
ياسر خليل أبو البراء قام بنشر مايو 30, 2015 الكاتب قام بنشر مايو 30, 2015 إخواني الكرام تنويه هام : تم التعديل بشكل كبير على الموضوع الأصلي وتمت إضافة كود آخر ليتناسب مع طلب الأخ نايف كما تمت إضافة معادلة صفيف .. أي ثلاثة حلول بالموضوع ... أخي الغالي سليم ارفق الملف الأول في المشاركة في الموضوع وضع الكود الخاص بك فيه وعدل عليه بما يتناسب مع النطاق معلش هتعبك معايا 1
سليم حاصبيا قام بنشر مايو 31, 2015 قام بنشر مايو 31, 2015 اخي الحبيب ياسر تفضل الملف الأول مع الكود تمت الإضافة للمشاركة الأولى للاستفادة من هذا الكود الرائع Missing Numbers YasserKhalil salim.rar
ياسر خليل أبو البراء قام بنشر مايو 31, 2015 الكاتب قام بنشر مايو 31, 2015 اخي الحبيب ياسر تفضل الملف الأول مع الكود بارك الله فيك أخي الحبيب سليم وجزاك الله خير الجزاء في الدنيا والآخرة تسلم على هذا الكود الممتاز قمت بإضافة الكود للمشاركة الأولى لتحقيق أقصى استفادة من الموضوع وبهذا تم تحديث الموضوع ووضع حلول جديدة .. ثلاثة أكواد وحل بالمعادلات ليكون مرجع للباحث في هذا الخصوص فيما بعد .. بدلاً من تضييع الوقت في موضوعات مكررة تقبل تحياتي
ياسر خليل أبو البراء قام بنشر يونيو 1, 2015 الكاتب قام بنشر يونيو 1, 2015 إخواني الكرام تم إضافة كود رابع وتحدث الملف في الموضوع الأصلي .. عشان محدش يقوووووووول إني حارمكم من حاجة لا تنسونا من صالح دعائكم تقبلوا تحياتي
دكتور محمد صلاح قام بنشر يونيو 2, 2015 قام بنشر يونيو 2, 2015 الاخوة الكرام استخدمت هذا الكود ولكن يبدا الارقام الناقصه من رقم 1 عاوز يكون اصغر رقم هوة مثلا 50000 وليس 1 كما تمت إضافة حل بمعادلات الصفيف لتؤدي نفس الغرض وإليكم أيضاً كود رائع للأخ الحبيب سليم حاصبيا مع شرح للأسطر ولا يشترط الترتيب للأرقام أيضاً
ياسر خليل أبو البراء قام بنشر يونيو 2, 2015 الكاتب قام بنشر يونيو 2, 2015 الأكواد مرنة وتبدأ من أي رقم وحتى لو الأرقام غير مرتبة ارفق ملفك للإطلاع عليه أخي الكريم
سليم الاخرس قام بنشر يونيو 2, 2015 قام بنشر يونيو 2, 2015 ماشاء الله تبارك الله ، بارك الله بجهودكم جميعا وبادارة الموقع ، نفعنا الله من علمكم واثابكم الخير والبركة .. تقبلوا مروري. طويلبكم سليم . 1
ياسر خليل أبو البراء قام بنشر يونيو 2, 2015 الكاتب قام بنشر يونيو 2, 2015 ماشاء الله تبارك الله ، بارك الله بجهودكم جميعا وبادارة الموقع ، نفعنا الله من علمكم واثابكم الخير والبركة .. تقبلوا مروري. طويلبكم سليم . بارك الله فيك أخي سليم وجزيت خيراً على مرورك العطر بالموضوع
دكتور محمد صلاح قام بنشر يونيو 3, 2015 قام بنشر يونيو 3, 2015 معذرة على التاخير اخى الكريم ونشكر لكم تعاونكم المفروض تكون الارقام الناقصة بدايه من اصغر رقم وليس من 1 test missing code.rar
ياسر خليل أبو البراء قام بنشر يونيو 3, 2015 الكاتب قام بنشر يونيو 3, 2015 دكتور محمد صلاح الملف المرفق صراحة لا يطاق استغرق حوالي 4 دقائق لفتحه عندي والتعامل صعب داخل المصنف رغم أنه لا يحوي إلا ورقة عمل واحدة عموماً بعد ما طلع روحي في ملفك جرب الكود التالي ستظهر النتائج في العمود المجاور العمود L Sub MissingNumbers_YK_B() 'يقوم الكود باستخراج الأرقام الناقصة في تسلسل للأرقام ولا يشترط الترتيب '------------------------------------------------------------------- 'تعريف المتغيرات Dim InputRange As Range Dim X As Long, lRow As Long 'تعيين النطاق الذي سيحتوي على سلسلة الأرقام المراد استخراج الأرقام الناقصة منها Set InputRange = Range("M7:M" & Cells(Rows.Count, "M").End(xlUp).Row) 'مسح محتويات النطاق الذي سيتم استخراج النتائج به Range("L7:L1000").ClearContents 'حلقة تكرارية من أقل قيمة بالنطاق لأكبر قيمة بالنطاق For X = WorksheetFunction.Min(InputRange) To WorksheetFunction.Max(InputRange) 'استخدام دالة البحث فإذا كانت القيمة المراد البحث عنها غير موجودة يعطي خطأ 'وبناءً على الخطأ يتم تنفيذ السطر التالي If IsError(Application.Match(X, InputRange, 0)) Then '[L] الرقم 7 هو رقم صف البداية في العمود '[L7] يتم وضع الرقم الناقص في الخلية في الصف المحدد في الخلية Cells(lRow + 7, "L") = X 'زيادة المتغير بمقدار واحد للانتقال لصف جديد لإدراج الأرقام الناقصة lRow = lRow + 1 End If Next X End Sub طبعاً الكود سيستغرق دقائق لأن عدد الأرقام الناقصة في ملفك حوالي 16000 وشوية تقبل تحياتي 2
دكتور محمد صلاح قام بنشر يونيو 3, 2015 قام بنشر يونيو 3, 2015 الاخ الكريم شاكر لكم تعاونكم هوة دا الكلام كدة مظبوط وهذا ما اريدة كدة بيجيب الارقام من اصغر كود الى اكبر كود بس موش من البدايه جزاكم الله الخير والسعادة احترامى لشخصكم الكريم 1
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.