البحث في الموقع
Showing results for tags 'rank edit'.
تم العثور علي 1 نتيجه
-
السلام عليكم ورحمة الله وبركاته السادة الأفاضل أساتذتى الكرام تحية طيبة وبعد مرفق شيت به كود أريد تعديلة ليتماشى مع المطلوب داخل الشيت ولسيادتكم خالص الشكر والتقدير 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
