نسخ صف الى صفوف مختلفه البدايه

Sub Test_CopyRow_Procedure()

    'أمثلة لكيفية استخدام الإجراء الفرعي

    '----------------------------------

    

    CopyRow "Data", 5

    CopyRow "Report", 7

    CopyRow "Final", 5

End Sub



Sub CopyRow(sSheet As String, sRow As Long)

'هذا الإجراء العام يقوم بنسخ آخر صف بعدد محدد من الصفوف بناءً على

'عدد 2 بارامتر الأول يمثل اسم ورقة العمل والثاني يمثل صف البداية

'--------------------------------------------------------------



    'تعريف المتغيرات

    Dim ws      As Worksheet

    Dim lr      As Long

    Dim lc      As Long

    Dim i       As Long



    'جملة لتجنب حدوث خطأ عند تعيين ورقة العمل

    On Error Resume Next

        

        'تعيين المتغير ليحمل ورقة العمل المعنية

        Set ws = Sheets(sSheet)

        

    'جملة لاستعادة خاصية تتبع الأخطاء

    On Error GoTo 0



    'إذا لم تكن هناك ورقة عمل بهذا الاسم

    If ws Is Nothing Then

    

        'تظهر رسالة تفيد بذلك ثم يتم الخروج من الإجراء الفرعي

        MsgBox "Sheet " & sSheet & " Doesn't Exists In The Workbook.", vbExclamation, "Sheet Not Found!"

        Exit Sub

    End If

    

    'تعطيل خاصية اهتزاز الشاشة

    Application.ScreenUpdating = False

    

        'تعيين قيمة للمتغير ليساوي عدد الصفوف المقرر إدراجها في أوراق العمل

        i = Sheets("Sheet1").Range("D5").Value

        

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

        lc = ws.Cells(sRow, Columns.Count).End(xlToLeft).Column

        

        'نسخ الصف المطلوب بدايةً من العمود الأول إلى آخر عمود

        ws.Range(ws.Cells(sRow, 1), ws.Cells(sRow, lc)).Copy

        

        'تحديد رقم آخر صف بورقة العمل المعنية مضافاً إليها 1 ليبدأ من أول صف جديد

        lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

        

        'لصق البيانات التي تم نسخها بداية من أول صف فارغ وبامتداد عدد الصفوف المقررة

        ws.Range("A" & lr).Resize(i).PasteSpecial xlPasteAll

        

        'مسح البيانات الثابتة فقط وليس المعادلات من النطاق الذي تم لصقه

        ws.Range("A" & lr).Resize(i, lc).SpecialCells(xlCellTypeConstants, 3).ClearContents

        

        'سطر للذهاب لأول خلية في ورقة العمل بعد القيام بعملية النسخ

        Application.Goto ws.Range("A1")

    

    'استعادة خاصية اهتزاز الشاشة

    Application.ScreenUpdating = True

End Sub

        'مسح البيانات الثابتة فقط وليس المعادلات من النطاق الذي تم لصقه

        ws.Range("A" & lr).Resize(i, lc).SpecialCells(xlCellTypeConstants, 3).ClearContents

.SpecialCells(xlCellTypeConstants, 3)

Option Explicit



Sub Test_CopyRow_Procedure()

    'أمثلة لكيفية استخدام الإجراء الفرعي

    '----------------------------------

 

    CopyRow "بيانات الطلبة", 9

    CopyRow "رصد الترم الأول", 10

    CopyRow "كنترول شيت (2)", 11

    CopyRow "رصد الترم الثانى", 10

    CopyRow "كنترول شيت", 10

    CopyRow "الحاله", 11

    CopyRow "كشف ناجح", 9

    CopyRow "أعمال السنة", 7

    CopyRow "تحريرى ف 2", 7

    CopyRow "إنجاز1", 7

    CopyRow "بيانات الطلبة", 9

    CopyRow "تحريرى ف 1", 7

   ' CopyRow "بيانات الطلبة", 9

    CopyRow "كشف الدور الثاني", 9





End Sub



Sub CopyRow(sSheet As String, sRow As Long)

'هذا الإجراء العام يقوم بنسخ آخر صف بعدد محدد من الصفوف بناءً على

'عدد 2 بارامتر الأول يمثل اسم ورقة العمل والثاني يمثل صف البداية

'--------------------------------------------------------------



    'تعريف المتغيرات

    Dim ws      As Worksheet

    Dim lr      As Long

    Dim lc      As Long

    Dim i       As Long



    'جملة لتجنب حدوث خطأ عند تعيين ورقة العمل

    On Error Resume Next

        

        'تعيين المتغير ليحمل ورقة العمل المعنية

        Set ws = Sheets(sSheet)

        

    'جملة لاستعادة خاصية تتبع الأخطاء

    On Error GoTo 0



    'إذا لم تكن هناك ورقة عمل بهذا الاسم

    If ws Is Nothing Then

    

        'تظهر رسالة تفيد بذلك ثم يتم الخروج من الإجراء الفرعي

        MsgBox "Sheet " & sSheet & " Doesn't Exists In The Workbook.", vbExclamation, "Sheet Not Found!"

        Exit Sub

    End If

    

    'تعطيل خاصية اهتزاز الشاشة

    Application.ScreenUpdating = False

    

        'تعيين قيمة للمتغير ليساوي عدد الصفوف المقرر إدراجها في أوراق العمل

        i = Sheets("Sheet1").Range("Q1").Value

        

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

        lc = ws.Cells(sRow, Columns.Count).End(xlToLeft).Column

        

        'نسخ الصف المطلوب بدايةً من العمود الأول إلى آخر عمود

        ws.Range(ws.Cells(sRow, 1), ws.Cells(sRow, lc)).Copy

        

        'تحديد رقم آخر صف بورقة العمل المعنية مضافاً إليها 1 ليبدأ من أول صف جديد

        lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

        

        'لصق البيانات التي تم نسخها بداية من أول صف فارغ وبامتداد عدد الصفوف المقررة

        ws.Range("A" & lr).Resize(i).PasteSpecial xlPasteAll

        

        'مسح البيانات الثابتة فقط وليس المعادلات من النطاق الذي تم لصقه

        ws.Range("A" & lr).Resize(i, lc).SpecialCells(xlCellTypeConstants, 3).ClearContents

        

        'سطر للذهاب لأول خلية في ورقة العمل بعد القيام بعملية النسخ

        Application.Goto ws.Range("A1")

    

    'استعادة خاصية اهتزاز الشاشة

    Application.ScreenUpdating = True

End Sub