بارك الله فى إخوتى الأحبة المشاركين فى الموضوع على هذا المجهود الرائع
ولاثراء الموضوع
هذا حل باستخدام كود آخر
Sub ragab()
Application.ScreenUpdating = False
LR = [A1000].End(xlUp).Row
[H3:I1000].ClearContents
For Each cl In Range("A3:A" & LR)
x = Application.WorksheetFunction.CountIf(Range("A3:A" & cl.Row), cl)
If x = 1 Then Arr = Arr & cl & ","
Next
Arr = Left(Arr, Len(Arr) - 1)
For Each c In Split(Arr, ",")
Cells([H1000].End(xlUp).Row + 1, 8) = c
Next
For Each cll In Range("H3:H" & [H1000].End(xlUp).Row)
For Each cel In Range("A3:A" & LR)
If cel = cll Then
cll.Offset(0, 1) = cll.Offset(0, 1) + cel.Offset(0, 1)
End If
Next
Next
Range("H3:I" & [I1000].End(xlUp).Row).Sort Key1:=Range("I3"), Order1:=xlDescending
Range("H13:I" & [I1000].End(xlUp).Row) = ""
Application.ScreenUpdating = True
End Sub
Top Ten 2.rar