هل يمكن البحث عن تكرار فى عمود معين واخذ قيمه مقابل التكرار واضافتها بعمود آخر؟

[essam rabea]

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

هل يمكن فى الاكسيل عمل ما هو موضح بالمرفق ... لكم جزيل الشكر

Book1.xlsx

[lionheart]

Sub Test()
    Const colResult As Integer = 4
    Dim a, x, ws As Worksheet, dic As Object, m As Long, i As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(1)
        With ws
            Set dic = CreateObject("Scripting.Dictionary")
            m = .Cells(Rows.Count, 1).End(xlUp).Row
            With .Columns(colResult)
                .ClearContents
                .Cells(1).Value = "Results"
            End With
            a = WorksheetFunction.Transpose(.Range("A1:B" & m).Value)
            For i = LBound(a, 2) To UBound(a, 2)
                If Not dic.Exists(a(1, i)) Then
                    dic.Add a(1, i), a(2, i)
                Else
                    dic.Item(a(1, i)) = dic.Item(a(1, i)) & ";" & a(2, i)
                End If
            Next i
            .Range("J1").Resize(UBound(dic.Keys) + 1) = Application.Transpose(dic.Keys)
            .Range("K1").Resize(UBound(dic.Items) + 1) = Application.Transpose(dic.Items)
            Set dic = Nothing
            With .Range("E2:E" & m)
                .Formula = "=COUNTIF($A$1:A2,A2)"
            End With
            For i = 2 To m
                x = Application.Match(.Cells(i, 1), .Columns(10), 0)
                If .Cells(i, 5) = 1 And Not IsError(x) Then
                    If InStr(.Cells(x, 11), ";") Then
                        .Cells(i, 4).Value = Mid(.Cells(x, 11).Value, InStr(.Cells(x, 11), ";") + 1)
                    End If
                End If
            Next i
            .Columns(5).ClearContents
            .Columns("J:K").ClearContents
        End With
    Application.ScreenUpdating = True
End Sub

 

[essam rabea]

أستاذنا lionheart

سلمت يداك