الأرقام الناقصة في المجموعة

[sof17]

المطلوب كود يستدعي الأصناف الناقصة في المجموعات

لدينا مجموعات من 1إلى 96 مثلا  وكل مجموع تحتوي على 100 صنف اريد معرفة الأصناف الناقصة في كل مجموع على الترتيب 

ولكن في هذا المثال عدد المجموعات من 1 إلى 3 فقط لكي يكون الكود سريع 

الملف

الأرقام الناقصة.xlsx

[محمد هشام.]

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

لمزيدا من التوضيح  يرجى ارفاق عينة لشكل  النتائج المتوقعة

[sof17]

النتائج المتوقعة والصحيحة 

الأرقام الناقصة.xlsx

[محمد هشام.]

تفضل اخي الكريم جرب هدا

Sub Find_MissingNumbers()
    Dim WS As Worksheet
    Dim CodeArr() As Variant, NumArr() As Variant, code As Variant
    Dim tmp As Object, ling As Long, cnt As Boolean, n As Boolean
    Dim lastRow As Long, i As Long, j As Long, maxNum As Long
    

    Set WS = Sheets("Sheet1")
    lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row
    maxNum = 100  '(عدد الأصناف) ' تحديد الحد الاقصى للقيم المفقودة

    n = False
    For i = 3 To lastRow
        If Not IsEmpty(WS.Cells(i, 1).Value) And Not IsEmpty(WS.Cells(i, 2).Value) Then
            n = True
            Exit For
        End If
    Next i
    
    If Not n Then
        MsgBox "الرجاء التحقق من البيانات والمحاولة مرة أخرى", vbExclamation
        Exit Sub
    End If

    Application.ScreenUpdating = False
    On Error Resume Next
    WS.Range("F3:G" & WS.Rows.Count).ClearContents
    CodeArr = WS.Range("A3:A" & lastRow).Value
    NumArr = WS.Range("B3:B" & lastRow).Value
    
    Set tmp = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(CodeArr, 1)
        If Not tmp.Exists(CodeArr(i, 1)) Then
            tmp.Add CodeArr(i, 1), New Collection
        End If
        tmp(CodeArr(i, 1)).Add NumArr(i, 1)
    Next i
    On Error GoTo 0
    
    ling = 3
    For Each code In tmp.Keys
        For j = 1 To maxNum
            cnt = False
            For i = 1 To tmp(code).Count
                If tmp(code)(i) = j Then
                    cnt = True
                    Exit For
                End If
            Next i
            If Not cnt Then
                WS.Cells(ling, 6).Value = code
                WS.Cells(ling, 7).Value = j
                ling = ling + 1
            End If
        Next j
    Next code

    Application.ScreenUpdating = True
End Sub

 

 

في حالة الرغبة بالحصول على رسالة تعرض "كود الصنف" وعدد "الأرقام المفقودة"   لكل صنف بعد تنفيد الكود قم بتعديل الجزء الأخير من الكود كالتالي 

ling = 3
    Dim msg As String, KyCount As Long
    msg = ": ملخص الأرقام المفقودة" & vbCrLf & vbCrLf
    For Each code In tmp.Keys
        KyCount = 0
        For j = 1 To maxNum
            cnt = False
            For i = 1 To tmp(code).Count
                If tmp(code)(i) = j Then
                    cnt = True
                    Exit For
                End If
            Next i
            If Not cnt Then
                WS.Cells(ling, 6).Value = code
                WS.Cells(ling, 7).Value = j
                ling = ling + 1
                KyCount = KyCount + 1
            End If
        Next j
        msg = msg & "كود الصنف: " & code & " - عدد الأرقام المفقودة: " & KyCount & vbCrLf
    Next code

    Application.ScreenUpdating = True
    MsgBox msg, vbInformation, "نتيجة الأرقام المفقودة"
End Sub

 

الأرقام الناقصة v1.xlsb

تم تعديل أكتوبر 13 بواسطه محمد هشام.

[sof17]

شكرا هذا هو المطلوب كود ممتاز

[sof17]

اخي هشام  ممكن الملخص يكون في الورقة 2 بدل ما يكون في الميساج بوكس احسن 

 

[محمد هشام.]

تفضل أخي  

Sub Find_MissingNumbers3()
    Dim WS As Worksheet, dest As Worksheet
    Dim CodeArr() As Variant, NumArr() As Variant, code As Variant
    Dim tmp As Object, ling As Long, cnt As Boolean, n As Boolean
    Dim lastRow As Long, i As Long, j As Long, maxNum As Long
    Dim msg As String, KyCount As Long

    Set WS = Sheets("Sheet1")
    Set dest = Sheets("Sheet2")

    lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row
    maxNum = 100  ' تحديد الحد الاقصى للقيم المفقودة

    n = False
    For i = 3 To lastRow
        If Not IsEmpty(WS.Cells(i, 1).Value) And Not IsEmpty(WS.Cells(i, 2).Value) Then
            n = True
            Exit For
        End If
    Next i
    
    If Not n Then
        MsgBox "الرجاء التحقق من البيانات والمحاولة مرة أخرى", vbExclamation
        Exit Sub
    End If

    Application.ScreenUpdating = False
   
    dest.Range("a2:b" & dest.Rows.Count).ClearContents
    WS.Range("F3:G" & WS.Rows.Count).ClearContents
    CodeArr = WS.Range("A3:A" & lastRow).Value
    NumArr = WS.Range("B3:B" & lastRow).Value
    
    Set tmp = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(CodeArr, 1)
        If Not tmp.Exists(CodeArr(i, 1)) Then
            tmp.Add CodeArr(i, 1), New Collection
        End If
        tmp(CodeArr(i, 1)).Add NumArr(i, 1)
    Next i
    
    dest.Cells(2, 1).Value = "كود الصنف"
    dest.Cells(2, 2).Value = "عدد الأرقام المفقودة"

    ling = 3
    Dim a As Long
    a = 3
    
    For Each code In tmp.Keys
        KyCount = 0
        For j = 1 To maxNum
            cnt = False
            For i = 1 To tmp(code).Count
                If tmp(code)(i) = j Then
                    cnt = True
                    Exit For
                End If
            Next i
            If Not cnt Then
                WS.Cells(ling, 6).Value = code
                WS.Cells(ling, 7).Value = j
                ling = ling + 1
                KyCount = KyCount + 1
            End If
        Next j
        dest.Cells(a, 1).Value = code
        dest.Cells(a, 2).Value = KyCount
        a = a + 1
    Next code

    Application.ScreenUpdating = True
    MsgBox dest.Name & " تم ترحيل ملخص الأرقام المفقودة إلى", vbInformation

End Sub

 

الأرقام الناقصة v2.xlsb

[sof17]

شكرا  استاذ هشام  وهو المطلوب 

اعذرني هناك  طلب اخر هل نسطيع تطبيق  نفس الفكرة  على جلب الأرقام المكرر بدل الناقصة 

[محمد هشام.]

منذ ساعه, sof17 said:

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

نعم اخي يمكننا فعل دالك حاول فتح موضوع جديد بطلبك مع ارفاق عينة للنتائج المطلوبة  وان شاء الله سوف نحاول مساعدتك 

[sof17]

شكررررررررا اخي هشام