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

السلام عليكم ورحمة الله وبركاته شرح دالة رانك ودالة اختيار Rank & Choose مرفق ملف العمل choose.xlsx

السلام عليكم ورحمة الله وبركاته مرفق الملف موضح به المطلوب Rank.rar

السلام عليكم ورحمة الله وبركاته إخوانى وأحبائى أعضاء وأساتذة ونجوم هذا الصرح العلمى العالمى العظيم بعد التحية قمت بطرح موضوع سابق من قبل طلبت فيه سحب بيانات معينة من تقرير لتقرير معين وتفضل الأستاذ القدير الفاضل / العيدروس بعمل لى هذا الكود العظيم وكان الكود رائع ولكنى أريد تعديل بسيط يقوم بتغيير نتيجة خانة معينة فى الشيت المطلوب نقل البيانات به إلى نتيجة معينة وباقى الخانات المطلوب بها النتائج ستظل كما هى موضح بالمرفق المطلوب الكود هو : 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 = 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 وتفضل أيضا الأخ الحبيب أستاذى ومعلمى القدير / ياسر خليل بتعديل طفيف فى الكود لتسريعة وكانت أيضا نتيجته ممتاذة والكود هو : 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 الرجاء المساعدة ولكم خالص الشكر والتقدير Rank.rar

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