كود بلغة HTML:
'==================Option Explicit'هذا الكود للمحترم ياسر خليل' الهدف من الكود نسخ صفوف بالعدد في يدايات مختلفه من صفحات مختلفه'يعمل الكود بعد مسح بيانات الطلاب القديمه'يعمل الكود في بدايات صفوف مختلفه في صفحات متعدده'تم هذا الكود في 22/8/2017Sub Test_CopyRow_Procedure() CopyRow "إدخال بيانات أساسية", 9 CopyRow "تقديرات تحريرى أخر العام ", 9 CopyRow "تقديرات و درجات نصف العام ", 9 CopyRow "سلول 5", 6 CopyRow "نتيجة بالمجموع أخر", 9 CopyRow "نتيجة بالمجموع نصف", 9 CopyRow "نتيجة الطلبة أخر العام ", 9 CopyRow "تحريرى ف 1", 9 CopyRow "تحريرى ف 2", 9 CopyRow "نتيجة الطلبة نصف العام", 9 CopyRow "مراجعة درجات أخر العام ", 9 CopyRow "شيت الرابع الرئيسى", 9 CopyRow " شيت نصف العام", 9 CopyRow "كشف تجميعى", 9 CopyRow "تقديرات تحريرى نصف العام ", 9 CopyRow " ملف الأنشطة", 9 CopyRow " تقديرات و درجات أخر العام ", 9 CopyRow "تقديرات نصف العام ", 9 CopyRow " ملف الإنجاز فصل 2", 9 CopyRow " تقديرات أخر العام", 9 CopyRow " تقديرات أخر العام", 9 CopyRow " ملف الإنجاز ف 1", 9 ' CopyRow "إجمالى", 7 CopyRow "مراجعة درجات نصف العام", 9'استعادة خاصية اهتزاز الشاشة Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True 'خليه وقوف المؤشر 'بعد الانتهاء من تنفيذ ادراج الصفوف Application.GoTo _ Sheets("إدخال بيانات أساسية").Range("B10") End SubSub 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 "ورقه " & sSheet & " غير موجوده.", vbExclamation, "ورقة غير موجودة!" Exit Sub End If 'مسح الصفوف ws.Rows(sRow + 1).Resize(1000).Clear 'تعيين قيمة للمتغير ليساوي عدد الصفوف المقرر إدراجها في أوراق العمل i = Sheets("إدخال بيانات أساسية") _ .Range("B7").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 SubFunction 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 = lngEnd Function
هذا هو الكود المتميز حقا
بارك الله في من اوجده
وبارك في كل من له بصمه في هذا