بحاجة الى كود ترحيل

Sub TrStuds()

Dim LR As Long, i As Long, C As Range

LR = Sheets("ÞÇÆãÉ äÕÝ ÇáÓäÉ").Range("A" & Rows.Count).End(3).Row

i = 7

Do While Range("R" & i) <> Empty

For Each C In Range("A7:A" & LR)

If C.Value = Range("R" & i) Then

C.Offset(0, 1) = Range("R" & i).Offset(0, 1)

C.Offset(0, 2) = Range("R" & i).Offset(0, 2)

End If

Next

i = i + 1

Loop

End Sub

Sub TrStuds()

Dim i As Long, C As Range

Dim Rng As Range, x As Integer

LR = Sheets("قائمة نصف السنة").Range("A" & Rows.Count).End(3).Row

Set Rng = Range("T7:T14")

x = WorksheetFunction.CountA(Rng)

If x = 0 Then

MsgBox "لا توجد اسماء لترحيلها . اكتب الاسماء اولا ثم اضغط زر ترحيل !!"

Exit Sub

End If

i = 7

Do While Range("R" & i) <> Empty



For Each C In Range("A7:A" & LR)

If C.Value = Range("R" & i) Then

C.Offset(0, 1) = Range("R" & i).Offset(0, 1)

C.Offset(0, 2) = Range("R" & i).Offset(0, 2)

End If

Next

i = i + 1

Loop

End Sub