طلب التعديل على كود

[hicham2610]

السلام عليكم

من فضلكم

كيف أعدل على الكود التالي:

Sub gestnoexamen()
Application.ScreenUpdating = False
    Range("T17").Select
    ActiveCell.FormulaR1C1 = "=COUNTIF(R17C6:RC[-14],RC[-14])"
    Range("T17").Select
    Selection.AutoFill Destination:=Range("T17:T72")
    Range("T17:T172").Select
    ActiveWorkbook.Worksheets("g").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("g").AutoFilter.Sort.SortFields.Add2 Key:=Range( _
        "T16"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("g").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("B17").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("B18").Select
    ActiveCell.FormulaR1C1 = "2"
    Range("B17:B18").Select
    Selection.AutoFill Destination:=Range("B17:B172")
    Range("B17:B172").Select
    Range("T9").Select
    Application.ScreenUpdating = True
End Sub

لكي لايحدد المدي المعين بالتحديد في العمود المعني (لBوT)إلى غاية السطر الذي به بيانات في العمود :    D

لأن البيانات قد تختلف فربما تكون أكثر أو أقل وليس دائما تفس عدد التلاميذ

الكود في زر توزيع المترشحين،الورقة : الملف مرفق

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

الملف الرئيسي1.xlsm

[hicham2610]

السلام عليكم

توصلت بالحل التالي ، أضعه هنا للإفادة:

Sub gestnoexamen()
Dim Dl As Integer

Dl = Cells(Rows.Count, "D").End(xlUp).Row    '' << trouve la dernière ligne

    Application.ScreenUpdating = False
    Range("T17").FormulaR1C1 = "=COUNTIF(R17C6:RC[-14],RC[-14])"
    Range("T17").AutoFill Destination:=Range("T17:T" & Dl)

    ActiveWorkbook.Worksheets("g").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("g").AutoFilter.Sort.SortFields.Add2 Key:=Range( _
            "T16"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("g").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Range("B17").FormulaR1C1 = "1"
    Range("B18").FormulaR1C1 = "2"
    Range("B17:B18").AutoFill Destination:=Range("B17:B" & Dl)

    Range("T9").Select
    Application.ScreenUpdating = True
MsgBox "تم توزيع المترشحين"
End Sub

والله ولي التوفيق