نجوم المشاركات

السلام عليكم اخي فضل جرب هذا الكود (ضعه في زر أمر) Sub Abu_Ahmed() On Error Resume Next Application.ScreenUpdating = False w = 7 For Each cl In [B2:B23] If cl = [N3] And cl.Offset(0, 1) = [N4] Then MyArr = MyArr & Trim(cl.Offset(0, -1)) & "," End If Next If MyArr = Empty Then GoTo 1 For Each c In Split(Mid(MyArr, 1, Len(MyArr) - 1), ",") Cells(w, 11) = c Cells(w, 12) = [N3] Cells(w, 13) = [N4] Cells(w, 14) = Application.VLookup(c, [A2:D23], 4, 0) w = w + 1 Next LR = [K1000].End(xlUp).Row Range(Cells(6, "K"), Cells(LR, "N")).Sort Key1:=Cells(6, "N"), Order1:=xlDescending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal If LR < 10 Then LR = 10 Range("K10:N" & LR).ClearContents 1: Application.ScreenUpdating = True End Sub