'هذا الكود للمحترم ياسر العربي
' الهدف من الكود هو نسخ صف الى صفوف تحته بالعدد المطلوب
'وقبل النسخ يتم مسح البيانات القديمه
'تاريخ الانشاء 30/7/2017
'تم التعديل على الكود بواسطه المحترم ياسر خليل لوجود متطلبات جديده
'=*=*=*=*=*=*=*=*=*=*=*=*=*=*
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim sh As Worksheet
Dim lr As Long
Dim lc As Long
Dim c As Long
Set ws = Sheets("بيانات الطلبة")
'خليه عدد الطلاب
c = ws.Range("Q1").Value
'خليه الرقم السري
If TextBox1.Text = ws.Range("F1") Then
Me.Hide
TextBox1.Text = ""
MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب", 64
Application.ScreenUpdating = False
Application.Calculation = xlManual
'اذا كان عدد المتقدمين اقل من اتنين يتم ايقاف الكود ولا يكمل
If ws.Range("Q1") < 2 Then
Exit Sub
End If
For Each sh In Sheets(Array("بيانات الطلبة", "إنجاز1", "تحريرى ف 1", "تحريرى ف 2", "أعمال السنة", "كشف ناجح", "الحاله", "كنترول شيت", "رصد الترم الثانى", "كنترول شيت (2)", "رصد الترم الأول", "كشف الدور الثاني"))
lr = IIf(LastOccupiedRowNum(sh) = 9, 9, LastOccupiedRowNum(sh))
lc = LastOccupiedColNum(sh)
'حذف البيانات الموجودة في النطاق المحدد
sh.Range("A10").Resize(Rows.Count - 9, lc).Clear
'نسخ الصف التاسع لكل شيت من حيث عدد الاعمدة الى العدد المحدد بعدد المتقدمين
sh.Range("A9").Resize(1, lc).AutoFill Destination:=sh.Range("A9").Resize(c, lc)
Next sh
Application.GoTo ws.Range("A1")
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Unload Me
Else
MsgBox "عفواً كلمة المرور خاطئه و لن يتم تنفيذ المطلوب", vbExclamation
TextBox1.Text = ""
TextBox1.SetFocus
End If
End Sub
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
End With
Else
lng = 1
End If
LastOccupiedRowNum = lng
End Function
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
End With
Else
lng = 1
End If
LastOccupiedColNum = lng
End Function
'==================================
Private Sub UserForm_Click()
End Sub
[8]
نسخ صف الى صفوف مختلفه البدايه
تحميل محتوى الموضوع
عرض نسخة صالحة للطباعة
أرسل هذا الموضوع إلى صديق
