تعديل كود فى شيت Rank

[Yasser Fathi Albanna]

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

السادة الأفاضل أساتذتى الكرام

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

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

ولسيادتكم خالص الشكر والتقدير

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
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 X = IIf(Vl = 3, X + 1, IIf(Vl = 4, X + Ar(R, 6), X + 1))
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 R, Rr, Cll
Set Sh = Sheets("Rank")
With Sh
Rr = 10: Cll = 24
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
Sub ClearConstants_1()
Dim Sh As Worksheet
Dim Rr, Cll
Set Sh = Sheets("Rank")
With Sh
Rr = 10: Cll = 24
 Union(.Range(Cells(Rr, 4), Cells(Cll, 4)), .Range(Cells(Rr, 9), Cells(Cll, 9)), _
.Range(Cells(Rr, 14), Cells(Cll, 14)), .Range(Cells(Rr, 19), Cells(Cll, 19))).ClearContents
End With
MsgBox "Greetings with Engineer / Yasser Fathi Al-Banna "
End Sub

 

Rank.rar

[Yasser Fathi Albanna]

للرفع 

جزاكم الله خيرا

[Yasser Fathi Albanna]

للرفع

ولسيادتكم خالص الشكر والتقدير

هل يوجد شيء فى المطلوب غير واضح

الرجاء الإفادة

[Yasser Fathi Albanna]

الأستاذ والمعلم القدير

ياسر خليل

بعد التحية

لقد تم إجابة حضرتك على هذا العمل من قبل بهذ الكود الرائع والسريع أيضا

ولكن أريد به تعديل بسيط جدا

الخانة التى إسمها P C أريد أن تعد فقط العميل مرة واحدة فقط حتى لو أخذ أكثر من فاتورة بتاريخ اليوم ويعد نفس العميل حتى لو أخذ فاتورة يوميا بس بتاريخ مختلف

يعنى العميل يعد مرة واحدة فقط مرتبط بالتاريخ

والكود كالتالى

Sub Test()
    Dim Coll As New Collection, CollDummy1 As New Collection, CollDummy2 As New Collection
    Dim ArrData, ArrIn, ArrOut1(), ArrOut2(), ArrOut3(), ArrOut4(), ArrCalc(), ArrTemp
    Dim I As Long, P As Long
    
    With Sheets("Report")
        ArrData = .Range("A2:F" & Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, 2))
    End With
    
    With Sheets("Rank")
        ArrIn = .Range("B10:B" & Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, 10))
    End With
    
    ReDim ArrOut1(1 To UBound(ArrIn, 1), 1 To 1)
    ReDim ArrOut2(1 To UBound(ArrIn, 1), 1 To 1)
    ReDim ArrOut3(1 To UBound(ArrIn, 1), 1 To 1)
    ReDim ArrOut4(1 To UBound(ArrIn, 1), 1 To 1)
    ReDim ArrCalc(1 To UBound(ArrData, 1), 1 To 2)
    
    On Error Resume Next
    For I = 1 To UBound(ArrData, 1)
        Set CollDummy1 = Nothing
        Set CollDummy2 = Nothing
        Coll.Add Key:=ArrData(I, 3), Item:=Array(Coll.Count + 1, CollDummy1, CollDummy2)
        ArrTemp = Coll(ArrData(I, 3))
        ArrTemp(1).Add Key:=ArrData(I, 4), Item:=Empty
        ArrTemp(2).Add Key:=ArrData(I, 1), Item:=Empty
        P = ArrTemp(0)
        ArrCalc(P, 1) = ArrCalc(P, 1) + ArrData(I, 6)
        ArrCalc(P, 2) = ArrCalc(P, 2) + 1
    Next I
    On Error GoTo 0
    
    For I = 1 To UBound(ArrIn, 1)
        On Error Resume Next
        ArrTemp = Coll(ArrIn(I, 1))
        If Err.Number = 0 Then
            ArrOut1(I, 1) = ArrCalc(ArrTemp(0), 1)
            ArrOut2(I, 1) = ArrCalc(ArrTemp(0), 2)
            ArrOut3(I, 1) = ArrTemp(1).Count
            ArrOut4(I, 1) = ArrTemp(2).Count
        End If
        On Error GoTo 0
    Next I
    
    Application.ScreenUpdating = False
        With Sheets("Rank")
            .Range("D10").Resize(UBound(ArrOut1, 1), 1).Value = ArrOut1
            .Range("I10").Resize(UBound(ArrOut2, 1), 1).Value = ArrOut2
            .Range("N10").Resize(UBound(ArrOut3, 1), 1).Value = ArrOut3
            .Range("S10").Resize(UBound(ArrOut4, 1), 1).Value = ArrOut4
        End With
    Application.ScreenUpdating = True
End Sub

ولسيادتكم خالص الشكر والتقدير

[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 = 24
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), 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

 

Rank.rar