تعديل جزء معين بكود للأستاذ العلامه القدير العيدروس

[Yasser Fathi Albanna]

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

إخوانى وأحبائى الأعزاء أعضاء وأساتذة عالم العلم والمعرفة بأوفيسينا

تحية طيبة وبعد

كنت قد طرحت موضوع من قبل عبارة عن 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

[عبد العزيز البسكري]

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

كمْ كان بودّي مساعدتك و لو بالقليل أستاذي الغالي " ياسر فتحي البنّا "

لكن مع هذا النّوع من الأكواد

" العين بصيرة و اليد قصيرة "

فائق إحتراماتي

 

[Yasser Fathi Albanna]

حبيبى الغالى / عبد العزيز

ربنا ما يحرمنيش منك أبدا أشكرك لإهتمامك

تقبل خالص تحياتى وتقديرى

فى إنتظار رد العمالقة

أو يتفضل الأستاذ القدير / العيدروس بتعديل المطلوب

مع خالص شكر وتقديرى للجميع

[الـعيدروس]

جرب هذا التعديل

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
Dim XX As Integer
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 Or Vl = 2 Then
        X = X + Ar(R, 6): XX = XX + 1
    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, IIf(Vl = 2, XX, 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(1, 2, .Cells(R, 2), False)
   .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

 

[Yasser Fathi Albanna]

أستاذى ومعلمى ملك الأكواد الرائعة الأستاذ الفاضل / العيدروس

سلمت يمينك وزادك الله من علمه وفضلة

وأدام عليك الصحة والعافية

هذا هو المطلوب بالضبط

تقبل خالص تحياتى وتقديرى لشخصكم الكريم

وشكرا لتعب حضرتك معايا

[الـعيدروس]

الاخ الحبيب ياسر فتحي

اشكرك على كلماتك الطيبه واخلاقك العاليه

تقبل تحياتي وشكري

 

[Yasser Fathi Albanna]

دا أقل ما يجب أن أقولة لحضرتك

أستاذى الفاضل / العيدروس

تقبل تحياتى