كود ترحيل دور ثان

[2saad]

أخواني أعضاء المنتدي الكرام بعد سلام الله عليكم ورحمته وبركاته

محتاج كود يرحل المسلسل والاسم ورقم الجلوس والفصل من شيت 1 الي شيت2   OSAMA.xlsm

وأمام كل تلميذ عنده ( دون المستوي أو غ ) في كل مادة في شيت 1 يضع أمامه في شيت 2علامة ( X )

ولكم جزيل الشكر ووافر الاحترام

[محمد هشام.]

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

Option Explicit
Sub test()

Dim lR&, lRow&
Dim Y As Range, R As Range

Dim wsCopy As Worksheet: Set wsCopy = Sheets("Sheet1")
Dim wsDest As Worksheet: Set wsDest = Sheets("Sheet2")

lRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row

Application.ScreenUpdating = False
   wsDest.Range("B10:K" & lRow).ClearContents
  
 With wsCopy
        lR = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
        .Range(.Cells(22, "B"), .Cells(lR, "E")).Copy wsDest.Cells(10, "B")
    End With
    
 With wsDest
    For Each Y In .Range("C10:C" & .Cells(Application.Rows.Count, 3).End(xlUp).Row)
        
        Set R = wsCopy.Columns(3).Find(Y.Value, , xlValues, xlPart)

If Not R Is Nothing And R.Offset(0, 4).Value = "غ" Or R.Offset(0, 4).Value = "دون المستوى" Then Y.Offset(0, 3).Value = "X"
 If Not R Is Nothing And R.Offset(0, 6).Value = "غ" Or R.Offset(0, 6).Value = "دون المستوى" Then Y.Offset(0, 4).Value = "X"
  If Not R Is Nothing And R.Offset(0, 8).Value = "غ" Or R.Offset(0, 8).Value = "دون المستوى" Then Y.Offset(0, 5).Value = "X"
   If Not R Is Nothing And R.Offset(0, 10).Value = "غ" Or R.Offset(0, 10).Value = "دون المستوى" Then Y.Offset(0, 6).Value = "X"
    If Not R Is Nothing And R.Offset(0, 12).Value = "غ" Or R.Offset(0, 12).Value = "دون المستوى" Then Y.Offset(0, 7).Value = "X"
     If Not R Is Nothing And R.Offset(0, 14).Value = "غ" Or R.Offset(0, 14).Value = "دون المستوى" Then Y.Offset(0, 8).Value = "X"
      
    Next Y
End With
    
    Application.ScreenUpdating = True
End Sub

 

OSAMA_V1.xlsm

[2saad]

شكرا جزيلا استاذنا الكبير محمد

وأنا آسف إني اتأخرت في الرد لأني كنت مسافر