ضبط كود للترحيل

Sub tarheel()

Dim ws As Worksheet, sh As Worksheet

Dim Arr As Variant, Temp As Variant

Dim LR As Long, i As Long, j As Long

Application.ScreenUpdating = False

Set ws = Sheets("Rsd")

ws.Range("D10:D" & ws.Range("C" & Rows.Count).End(xlUp).Row).ClearContents

Set sh = Sheets("seer")

LR = sh.Range("C" & Rows.Count).End(xlUp).Row

Arr = sh.Range("A5:E" & LR).Value

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

For i = 1 To UBound(Arr, 1) Step 4

If Arr(i, 3) <> "" Then

p = p + 1

For j = 1 To 4

Temp(p, j) = Arr(i, Choose(j, 1, 2, 3, 5))

Next



End If

Next

If p > 0 Then ws.Range("A10").Resize(p, UBound(Temp, 2)).Value = Temp

Application.ScreenUpdating = True

End Sub

Sub New_tarheel()

Dim ws As Worksheet, sh As Worksheet

Dim LR%, i%, m%

m = 10

Set ws = Sheets("Rsd")

Set sh = Sheets("seer")

ws.Range("D10", Range("D9").End(4)).ClearContents

LR = sh.Range("C" & Rows.Count).End(xlUp).Row

For i = 5 To LR Step 4

 ws.Cells(m, 4) = sh.Cells(i, 5)

 m = m + 1

Next

End Sub

Sub New_tarhel()

Dim ws As Worksheet, sh As Worksheet

Dim LR%, i%

Dim Rg As Range



Set ws = Sheets("Rsd")

Set sh = Sheets("seer")

ws.Range("D10", Range("D9").End(4)).ClearContents

Set Rg = sh.Range("E5:E500").SpecialCells(2)

Rg.Copy

 ws.Cells(10, "D").PasteSpecial (12)

 Application.CutCopyMode = False

 ws.Cells(10, "D").Select

End Sub

Sub Transfer_Data_In_Merged_Cells_From_Sheet_To_Another()

    Rem الإعلان عن المتغيرات ومنها مصفوفة سيكون عدد الأعمدة فيها 4 وتعبر عن النتائج

    Dim a(1 To 10000, 1 To 4), ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long

    Rem إيقاف اهتزاز الشاشة لتسريع الكود

    Application.ScreenUpdating = False

        Rem تعيين ورقة العمل التي يتم ترحيل البيانات منها

        Set ws = ThisWorkbook.Worksheets("seer")

        Rem تعيين ورقة العمل التي يتم ترحيل البيانات إليها

        Set sh = ThisWorkbook.Worksheets("Rsd")

        Rem تحديد رقم آخر صف به بيانات بناءً على العمود الثالث في ورقة البيانات

        lr = ws.Cells(Rows.Count, "C").End(xlUp).Row

        Rem حلقة تكرارية من الصف الخامس لآخر صف به بيانات وبتخطي 4 صفوف

        For r = 5 To lr Step 4

            Rem استخدام المتغير كعداد ويزيد في كل مرة بمقدار واحد

            m = m + 1

            Rem وضع المسلسل في أول عمود في المصفوفة

            a(m, 1) = m

            Rem وضع رقم الجلوس في العمود الثاني في المصفوفة

            a(m, 2) = ws.Cells(r, 2).Value  'Seat Number

            Rem وضع اسم الطالب في العمود الثالث في المصفوفة

            a(m, 3) = ws.Cells(r, 3).Value  'Student Name

            Rem وضع درجة الطالب في العمود الرابع في المصفوفة

            a(m, 4) = ws.Cells(r, 5).Value  'Mark

        Rem الانتقال للمجموعة التالية بعد تخطي 4 صفوف

        Next r

        Rem بدء التعامل مع الخلية في ورقة العمل التي سيتم ترحيل البيانات إليها

        With sh.Range("A10")

            Rem مسح النطاق بدايةً من الخلية وبامتداد 4 أعمدة مع استثناء أول 9 صفوف

            .Resize(Rows.Count - 9, 4).ClearContents

            Rem وضع نتائج المصفوفة في ورقة العمل الهدف

            .Resize(UBound(a, 1), UBound(a, 2)).Value = a

        End With

    Rem استرجاع خاصية اهتزاز الشاشة في نهاية الكود

    Application.ScreenUpdating = True

End Sub