طريقة ترحيل الدور الثانى من الشيت كنترول

Sub TransRes()

Dim ws As Worksheet, Nag As Worksheet, Ras As Worksheet

Dim LR As Long, i As Long, j As Long, jj As Long, N As Long, R As Long

Dim Arr As Variant, TmpN As Variant, TmpR As Variant

Set ws = Sheets("شيت ")

Set Nag = Sheets("الناجحون")

Set Ras = Sheets("دور ثان")

Application.ScreenUpdating = False

LR = ws.Range("B" & Rows.Count).End(xlUp).Row

Nag.Range("A7:AE" & Nag.Range("A" & Rows.Count).End(xlUp).Row + 6).ClearContents

Ras.Range("A7:AF" & Nag.Range("A" & Rows.Count).End(xlUp).Row + 6).ClearContents

Arr = ws.Range("A7:AF" & LR).Value

ReDim TmpN(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))

ReDim TmpR(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))

For i = 1 To UBound(Arr, 1)

If Arr(i, 31) = "ناجح" Then

N = N + 1

For j = 1 To 31

TmpN(N, j) = Arr(i, j)

TmpN(N, 1) = N

Next

ElseIf Arr(i, 31) = "دور ثان" Then

R = R + 1

For jj = 1 To 32

TmpR(R, jj) = Arr(i, jj)

TmpR(R, 1) = R



Next

End If

Next

If N > 0 Then Nag.Range("A7").Resize(N, 31).Value = TmpN

If R > 0 Then Ras.Range("A7").Resize(R, 32).Value = TmpR

Application.ScreenUpdating = True

End Sub