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

[ناصر سعيد]

الكود في حلته النهائيه يحفظ الله الاستاذ الخلوق ياسر خليل
صاحب هذا الكود الرائع ويحفظ الله كل من كانت له بصمه في اخراج هذا العمل

ويرحم امواتنا

الكود مهم جدا لرجال التربيه والتعليم ( الكنترولات ) لتخفيف حجم البرنامج ليعمل على عدد الطلاب فقط  مهما كان عددهم

وينسخ المعدلات يعني ماعليك الا ان تضع معادلاتك في الصف الذي يلي العنوان فقط والكود ينسخها بالعدد .. حقا رائع

'==================

Option Explicit
'هذا الكود للمحترم ياسر خليل
' الهدف من الكود نسخ صفوف بالعدد في يدايات مختلفه من صفحات مختلفه
'يعمل الكود بعد مسح بيانات الطلاب القديمه
'يعمل الكود في بدايات صفوف مختلفه في صفحات متعدده
'تم هذا الكود في   22/8/2017

Sub Test_CopyRow_Procedure()

       'أمثلة لكيفية استخدام الإجراء الفرعي
  CopyRow "بيانات الطلبة", 9
    CopyRow "رصد الترم الثانى", 10
    CopyRow "كنترول شيت", 10
    CopyRow "الحاله", 11
    CopyRow "كشف ناجح", 9
    CopyRow "أعمال السنة", 7
    CopyRow "تحريرى ف 2", 7
    CopyRow "إنجاز1", 7
    CopyRow "بيانات الطلبة", 9
    CopyRow "تحريرى ف 1", 7
    CopyRow "كشف الدور الثاني", 9
  CopyRow "رصد الترم الأول", 10
 CopyRow "كنترول شيت (2)", 11

'استعادة خاصية اهتزاز الشاشة
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    Application.Goto Sheets("بيانات الطلبة").Range("A1")
End Sub

Sub CopyRow(sSheet As String, sRow As Long)
    Dim ws      As Worksheet
    Dim lr      As Long
    Dim lc      As Long
    Dim i       As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    'جملة لتجنب حدوث خطأ عند تعيين ورقة العمل
    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
    'مسح الصفوف
    ws.Rows(sRow + 1).Resize(1000).Clear
    
       'تعيين قيمة للمتغير ليساوي عدد الصفوف المقرر إدراجها في أوراق العمل
    i = Sheets("بيانات الطلبة").Range("Q1").Value - 1
    lc = LastRowColumn(ws, "C")
    
   'تحديد رقم آخر صف بورقة العمل المعنية مضافاً إليها 1 ليبدأ من أول صف جديد
    lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    
    On Error Resume Next
    
    
    ws.Range(ws.Cells(sRow, 1), ws.Cells(sRow, lc)).Copy
    
        'لصق البيانات التي تم نسخها بداية من أول صف فارغ وبامتداد عدد الصفوف المقررة
    ws.Range("A" & lr).Resize(i).PasteSpecial xlPasteAll
    
          'مسح البيانات الثابتة فقط وليس المعادلات من النطاق الذي تم لصقه
    ws.Range("A" & lr).Resize(i, lc).SpecialCells(xlCellTypeConstants, 3).ClearContents

   'سطر للذهاب لأول خلية في ورقة العمل بعد القيام بعملية النسخ
    Application.Goto ws.Range("A1")
End Sub

Function LastRowColumn(ws As Worksheet, rc As String) As Long
    Dim lng     As Long

    If Application.WorksheetFunction.CountA(ws.Cells) <> 0 Then
        With ws
            If UCase(rc) = "R" Then
                lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
            ElseIf UCase(rc) = "C" Then
                lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
            End If
        End With
    Else
        lng = 1
    End If

    LastRowColumn = lng
End Function

وهذا هو المرفق
نسـخ صفوف في صفحات مختلفه 1.rar

 

 

نسـخ صفوف في صفحات مختلفه 1.rar