T4724_Transfer Students Information SpecialCells Areas

https://excel-egy.com/forum/t4724
---------------------------------

Sub Transfer_Students_Information_Loop_Through_SpecialCells_Areas()
    Dim a, ws As Worksheet, sh As Worksheet, myAreas As Areas, i As Long, j As Long, r As Long, m As Long, n As Long, x As Long

    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(1)
        Set sh = ThisWorkbook.Worksheets(2)
        Set myAreas = ws.Columns(8).SpecialCells(2).Areas
        m = 3

        For i = 1 To myAreas.Count
            r = myAreas(i).Row + 10
            sh.Cells(m, 2).Value = Trim(Split(ws.Cells(r, "AC").Value, "اسم الطالب:")(1))
            sh.Cells(m, 3).Value = Trim(Replace(Replace(ws.Cells(myAreas(i).Row, "H").Value, "الصف", ""), "الابتدائي", ""))
            sh.Cells(m, 4).Value = ws.Cells(r, "U").Value

            n = myAreas(i).Row + 17

            For j = 1 To 8
                x = n + j - 1
                a = Array(ws.Cells(x, "AA").Value, ws.Cells(x, "V").Value, ws.Cells(x, "Q").Value, ws.Cells(x, "N").Value)
                sh.Cells(m, 4 * j + 1).Resize(, UBound(a) + 1).Value = a
            Next j
            m = m + 1
        Next i
    Application.ScreenUpdating = True
End Sub