مطلوب تعديل كود ترحيل

[علي عبد المنعم]

 

برجاء المساعدة في تعديل كود ترحيل

نتيجة الدور الثاني.rar

[ياسر خليل أبو البراء]

السلام عليكم

جرب التعديل التالي عله يفي بالغرض

Sub Test()
    Dim ws      As Worksheet
    Dim sh      As Worksheet
    Dim r       As Long
    Dim m       As Long

    Set ws = Sheets("تسجيل الدرجات")
    Set sh = Sheets("دور ثاني")
    m = 11

    Application.ScreenUpdating = False
    For r = 11 To 307 Step 2
        sh.Range("E" & r & ":CT" & r).ClearContents
    Next r

    For r = 8 To 306
        If ws.Cells(r, 3) = "راسب" Then
            sh.Range("E" & m).Resize(1, 95).Value = ws.Range("D" & r).Resize(1, 95).Value
            m = m + 2
        End If
    Next r
    Application.ScreenUpdating = True

    MsgBox ("الحمد لله تـــم الترحيل ")
End Sub

 

[سليم حاصبيا]

ربما ينفع هذا الكود

Option Explicit
Sub Tarhil()
    Dim First, Sec As Worksheet
    Dim m, n, x As Long
 
    Set First = Sheets("تسجيل الدرجات")
    Set Sec = Sheets("دور ثاني")
    m = 11
    Application.ScreenUpdating = False
    For n = 6 To 154
        x = 2 * n - 1: Sec.Range("E" & x & ":CT" & x).ClearContents
    Next

    For n = 8 To x - 2
        If First.Cells(n, 3) = "راسب" Then
            Sec.Range("E" & m).Resize(1, 95).Value = First.Range("D" & n).Resize(1, 95).Value
            m = m + 2
        End If
    Next
    Application.ScreenUpdating = True

    MsgBox ("That Is All ")
End Sub