السلام عليكم ورحمة الله
استخدم هذا الكود و اربطه بزر فى ورقة "شيت"
CODE
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
طريقة ترحيل الدور الثانى من الشيت كنترول
