البحث في الموقع

السلام عليكم ورحمة الله وبركاته إخوانى وأحبائى الأعزاء أعضاء وأساتذة عالم العلم والمعرفة بأوفيسينا تحية طيبة وبعد كنت قد طرحت موضوع من قبل عبارة عن Rank يسحب داتا معينة من Report وقام السيد الفاضل الأستاذ القدير / العيدروس بعمل لى كود أكثر من روعة وقمت بطرح هذا الكود للتعديل عليه مرة أخرى لسحبها بطريقة ما وتفضل أيضا أستاذى ومعلمى القدير / العيدروس بتعديلة اليوم أطرح نفس الكود لتعديل جزء بسيط به خاص بخانة معينة داخل Rank مظللة باللون الأصفر لتعطى النتيجة الموضحة داخل اللون الأصفر وهى عبارة عن جميع الأصناف المباعة للمندوب حتى لو مكررة أى كاملة مرفق الملف وبه الكود وأيضا الكود موضح الرجاء المساعدة ولسيادتكم خالص الشكر والتقدير مع وافر التحية Private Function Ali(Ln As Long, Vl, Bl As String, Bln As Boolean) Dim Shet As Worksheet Dim Do_Ali Dim Ar() As Variant Dim iCnt& Dim X, A On Error Resume Next Set Shet = Sheets("Report") Set Do_Ali = CreateObject("Scripting.Dictionary") With Application .ScreenUpdating = False .EnableEvents = True DoEvents With Shet Lr = .Cells(.Rows.Count, 2).End(xlUp).Row Ar = .Range("A2:F" & Lr).Value: A = Bl For R = LBound(Ar, 1) To UBound(Ar, 1) If Ar(R, 3) = A Then If Not Bln Then If Vl = 3 Then ZZ = Ar(R, 2): ZZZ = Ar(R - 1, 2) If ZZZ <> ZZ Then X = X + 1 End If End If If Vl = 4 Then X = X + Ar(R, 6) End If End If If Do_Ali.exists(Ar(R, Ln)) Then Do_Ali.Item(Ar(R, Ln)) = Do_Ali.Item(Ar(R, Ln)) + 1 Else Do_Ali.Add Ar(R, Ln), 1 End If End If Next Ali = IIf(Vl = 1, Do_Ali.Count, X) End With .ScreenUpdating = True .EnableEvents = False End With Erase Ar Set Do_Ali = Nothing Set Shet = Nothing End Function Sub Ali_Count() Dim Sh As Worksheet Dim Sht As Worksheet Dim R, Rr, Cll, Lrr Set Sh = Sheets("Rank") Set Sht = Sheets("Report") With Sh Lrr = Sht.Cells(Rows.Count, 2).End(xlUp).Row Sht.Sort.SortFields.Add Key:=Sht.Range("A2:A" & Lrr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With Sht.Sort .SetRange Sht.Range("A1:F" & Lrr) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Rr = 10: Cll = 13 For R = Rr To Cll If .Cells(R, 2) <> "" Then .Cells(R, 4) = Ali(1, 4, .Cells(R, 2), False) .Cells(R, 9) = Ali(1, 3, .Cells(R, 2), False) .Cells(R, 14) = Ali(4, 1, .Cells(R, 2), True) .Cells(R, 19) = Ali(1, 1, .Cells(R, 2), True) End If Next End With MsgBox "Greetings with Engineer / Yasser Fathi Al-Banna " End Sub Rank End.rar