Sub TrnsfrData()
Dim Dta As Worksheet, ws As Worksheet
Dim Arr As Variant, Temp As Variant
Dim Rng As Range, i As Long, j As Long, p As Long
Dim StrDate As String, C As Range
Const NewInput As String = "دخول جديد"
Const Remov As String = "شطب"
Const ChngCas As String = "تغيير الصفة"

Set Dta = Sheets("data")
Set ws = Sheets("حركة التلاميذ")
T = Timer
Application.ScreenUpdating = False
ws.Range("A11:K30").ClearContents
Set Rng = Dta.Range("A7:U26")
StrDate = ws.Range("G6")
Arr = Rng.Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 18) = StrDate Or Arr(i, 19) = StrDate Then
p = p + 1
For j = 1 To 10
Temp(p, j) = Arr(i, Choose(j, 1, 2, 3, 6, 7, 8, 9, 14, 20, 21))
Temp(p, 1) = p
Next
End If
Next
If p > 0 Then ws.Range("A11").Resize(p, UBound(Temp, 2)).Value = Temp
For Each C In ws.Range("I11:I30")
If Not IsEmpty(C) And Not IsEmpty(C.Offset(0, 1)) Then
C.Offset(0, 2) = ChngCas
ElseIf Not IsEmpty(C) Then
C.Offset(0, 2) = NewInput
ElseIf Not IsEmpty(C.Offset(0, 1)) Then
C.Offset(0, 2) = Remov
Else
C.Offset(0, 2) = Empty

End If
Next
Application.ScreenUpdating = True
MsgBox Round(Timer - T, 2)
End Sub