طلب كود

[sof17]

 

جلب الأرقام المكررة 

كما هو موضح في الملف

الأرقام المكررة.xlsx

[محمد هشام.]

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

تفضل أخي تم تنفيد طلبك بنفس الفكرة إستخراج الأرقام المكررة مع ترحيل التقرير لورقة2 يتضمن إسم الصنف - القيمة المكررة - عدد التكرارات 

Const Item As Long = 2   '  تحديد أدنى عدد للتكرارات المطلوبة

Sub Find_DuplicatedNumbers()
    Dim WS As Worksheet, dest As Worksheet
    Dim CodeArr() As Variant, f() As Variant, code As Variant
    Dim tmp As Object, ligne As Long, a As Long
    Dim lastRow As Long, i As Long, key As Variant
    Dim dict As Object, n As Boolean
    Dim Rng As Range, c As Range, LR As Long
    
    Set WS = Sheets("Sheet1")
    Set dest = Sheets("Sheet2")

    lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row
    
    On Error Resume Next
    CodeArr = WS.Range("A3:A" & lastRow).Value
    f = 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), CreateObject("Scripting.Dictionary")
        End If
    On Error GoTo 0
    
        If tmp(CodeArr(i, 1)).Exists(f(i, 1)) Then
            tmp(CodeArr(i, 1))(f(i, 1)) = tmp(CodeArr(i, 1))(f(i, 1)) + 1
        Else
            tmp(CodeArr(i, 1))(f(i, 1)) = 1
        End If
    Next i

    n = False
    For Each code In tmp.Keys
        Set dict = tmp(code)
        For Each key In dict.Keys
            If dict(key) >= Item Then
                n = True
                Exit For
            End If
        Next key
        If n Then Exit For
    Next code
    
    If Not n Then MsgBox "لا توجد أي تكرارات للقيم", vbInformation: Exit Sub
    Application.ScreenUpdating = False
    LR = WS.Cells(WS.Rows.Count, "F").End(xlUp).Row
    WS.Range("F3:G" & LR).Borders.LineStyle = xlNone

    dest.Range("A2:C" & dest.Rows.Count).ClearContents
    WS.Range("F3:G" & WS.Rows.Count).ClearContents
    
    dest.Cells(2, 1).Resize(1, 3).Value = Array("كود الصنف", "القيمة المكررة", "عدد مرات التكرار")

    ligne = 3
    a = 3
    For Each code In tmp.Keys
        Set dict = tmp(code)
        For Each key In dict.Keys
            If dict(key) >= Item Then
                WS.Cells(ligne, 6).Value = code
                WS.Cells(ligne, 7).Value = key
                ligne = ligne + 1
                dest.Cells(a, 1).Resize(1, 3).Value = Array(code, key, dict(key))
                a = a + 1
            End If
        Next key
    Next code

    LR = WS.Cells(WS.Rows.Count, "F").End(xlUp).Row
    Set Rng = WS.Range("F3:G" & LR)

    For Each c In Rng.Rows
        If Application.WorksheetFunction.CountA(c) > 0 Then
            c.Borders.LineStyle = xlContinuous
        End If
    Next c

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

End Sub

 

الأرقام المكررة.xlsb

[sof17]

شكررررررررا اخي هشام هو المطلوب