معرفة الأرقام الناقصة Missing Numbers في سلسلة أرقام

[ياسر خليل أبو البراء]

 

إخواني الكرام في المنتدى الغالي

 

أقدم لكم اليوم موضوع ليس بالجديد ولكنه جد مفيد (جد .. يعني جداً أوك يا جدو) ..أقصد مفيد جداً

 

الموضوع يتمحور ويتمركز حول معرفة الأرقام المفقودة أو الأرقام الناقصة في سلسلة أرقام ..

 

إليكم الكود الأول المؤدي للغرض (هنا يشترط ترتيب الأرقام) ، مع شرح تفصيلي لأسطر الكود لتتمكن من التعديل عليه

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 ومهدى للأخ الفاضل نايف - م)

حمل الملف من هنا

 

تقبلوا تحياتي

[محمد حسن المحمد]

جزاكم الله خيراً...

روح الدعابة ...والجد في العمل ...والنتائج الصحيحة

إن الكلمات لتعجز عن تصوير مشاعر الإعجاب

بارك الله لك وبك وعليك أبا البراء الغالي..

[سليم حاصبيا]

اكثر من رائع اخي ياسر

 وما رأيك بعمل نفس الشيء بواسطة المعادلات

ارقام ناقصة.rar

[ياسر خليل أبو البراء]

الأخوة الكرام

مشكور على مرروكم العطر

 

الأخ الغالي أبو يوسف

جزيت خيراً على مرورك العطر ومشكور على كلماتك الرقراقة العذبة التي تسعد القلوب ..لا حرمنا الله منك

 

الأخ الحبيب سليم

دائماً ما تتحفنا بهداياك القيمة

 

الأخ الفاضل نايف

لما لا تقوم بترتيب الأرقام ثم تنفيذ الكود لتحصل على المطلوب

[سليم حاصبيا]

الاخ نايف

تم العمل كما تريد

serie non reguliee.rar

[نايف - م]

أستاذي الكريم ياسر

يمكن ترتيب الأرقام ثم تنفيذ الكود

لكن الترتيب يكون تصاعدي في عمود آخر يحوي الباركود للدواء

الأخ الكريم سليم

سأقوم بالتجريب و لأخبارك

شكرا لك

[صلاح الصغير]

ا / سليم  

ا / ياسر

 

اكثر من رائع بارك الله فيكم

[الزباري]

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

[سليم حاصبيا]

اخي نايف 

اليك ما تريد بواسطة الكود,فليكن ذلك (هو انا يهمني -على رأي الفنان عادل امام)

انظر الى الصفحة  Mydata

serie non reguliee (vba).rar

[Yasser Fathi Albanna]

سلمت يمينك أخى الحبيب / ياسر خليل

قمة الروعة

تقبل تحياتى وتقديرى

[ياسر خليل أبو البراء]

أخي الحبيب سليم بارك الله فيك جزاك الله كل خير

 

الأخ الكريم نايف والأخوة الكرام

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

 

الأخ الحبيب ياسر فتحي / الأخ الغالي الزباري / الأخ الكريم صلاح الصغير

مشكور على مرروكم العطر بالموضوع ، بارك الله فيكم

 

تقبلوا تحياتي

[عبد العزيز البسكري]

بارك الله فيك و جزاك الله خيرًا

[ياسر خليل أبو البراء]

الأخ عبد العزيز البسكري

جزيت خيراً على مرورك العطر

 

نداء إلى أخي الحبيب سليم

يرجى تطبيق الكود الخاص بك على الملف الأصلي في النطاق A5:A وحتى آخر صف ..شوف النتائج ...............الكود بيحصل إنه بيهنج ولابد من الضغط على Ctrl + End لينتهي عمل الكود !! ويعطي نتائج أكثرمن اللازم

[سليم حاصبيا]

الكود عندي اشتغل بشكل طبيعي جداً

و ليس هناك من حلقات تكلرارية لا نهائية 

عندي الاوفيس 2010 و لا اعلم اذا كانت هناك مشكلة بالنسبة للكود في باقي الاصدارات

[ياسر خليل أبو البراء]

إخواني الكرام

تنويه هام :

تم التعديل بشكل كبير على الموضوع الأصلي وتمت إضافة كود آخر ليتناسب مع طلب الأخ نايف كما تمت إضافة معادلة صفيف ..

أي ثلاثة حلول بالموضوع ...

 

أخي الغالي سليم

ارفق الملف الأول في المشاركة في الموضوع وضع الكود الخاص بك فيه وعدل عليه بما يتناسب مع النطاق

معلش هتعبك معايا

[سليم حاصبيا]

اخي الحبيب ياسر

تفضل الملف الأول مع الكود

 

تمت الإضافة للمشاركة الأولى للاستفادة من هذا الكود الرائع

Missing Numbers YasserKhalil salim.rar

[ياسر خليل أبو البراء]

اخي الحبيب ياسر

تفضل الملف الأول مع الكود

بارك الله فيك أخي الحبيب سليم وجزاك الله خير الجزاء في الدنيا والآخرة

تسلم على هذا الكود الممتاز

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

وبهذا تم تحديث الموضوع ووضع حلول جديدة ..

ثلاثة أكواد وحل بالمعادلات ليكون مرجع للباحث في هذا الخصوص فيما بعد .. بدلاً من تضييع الوقت في موضوعات مكررة

 

تقبل تحياتي

[ياسر خليل أبو البراء]

إخواني الكرام

تم إضافة كود رابع وتحدث الملف في الموضوع الأصلي .. عشان محدش يقوووووووول إني حارمكم من حاجة

لا تنسونا من صالح دعائكم

تقبلوا تحياتي

[دكتور محمد صلاح]

الاخوة الكرام استخدمت هذا الكود ولكن يبدا الارقام الناقصه من رقم 1 عاوز يكون اصغر رقم هوة مثلا 50000 وليس 1

 

 

كما تمت إضافة حل بمعادلات الصفيف لتؤدي نفس الغرض

 

وإليكم أيضاً كود رائع للأخ الحبيب سليم حاصبيا مع شرح للأسطر ولا يشترط الترتيب للأرقام أيضاً

[ياسر خليل أبو البراء]

الأكواد مرنة وتبدأ من أي رقم وحتى لو الأرقام غير مرتبة

ارفق ملفك للإطلاع عليه أخي الكريم

[سليم الاخرس]

ماشاء الله تبارك الله ، بارك الله بجهودكم جميعا وبادارة الموقع ، نفعنا الله من علمكم واثابكم الخير والبركة ..

تقبلوا مروري.

 

طويلبكم سليم .

[ياسر خليل أبو البراء]

ماشاء الله تبارك الله ، بارك الله بجهودكم جميعا وبادارة الموقع ، نفعنا الله من علمكم واثابكم الخير والبركة ..

تقبلوا مروري.

 

طويلبكم سليم .

بارك الله فيك أخي سليم وجزيت خيراً على مرورك العطر بالموضوع

[دكتور محمد صلاح]

معذرة على التاخير اخى الكريم ونشكر لكم تعاونكم

 

 

المفروض تكون الارقام الناقصة بدايه من اصغر رقم وليس من 1

test missing code.rar

[ياسر خليل أبو البراء]

دكتور محمد صلاح

الملف المرفق صراحة لا يطاق استغرق حوالي 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 وشوية

 

تقبل تحياتي

[دكتور محمد صلاح]

الاخ الكريم شاكر لكم تعاونكم هوة دا الكلام كدة مظبوط وهذا ما اريدة كدة بيجيب الارقام من اصغر كود الى اكبر كود بس موش من البدايه 

 

جزاكم الله الخير والسعادة  

 

احترامى لشخصكم الكريم