تحميل محتوى الموضوع
عرض نسخة صالحة للطباعة
أرسل هذا الموضوع إلى صديق
في هذا الكود الاكثر من رائع يمسح وينسخ الصفوف دائما من صف موحد معين .. لو تمت ان تكون العناوين في الصفحات المختلفه في صفوف مختلفه وليست صف البدايه موحد ... تكون غير عاديه ربنا يزيدكم علما وخلقا
يعني مثلا الصفحه الاولى والتانيه تبدا من الصف التاسع..
والصفحه التالته من الصف السابع..
والرابعه من الصف الثامن .. يعني بدايات مختلفه جزاكم الله خيرا
'هذا الكود للمحترم ياسر العربي
' الهدف من الكود هو نسخ صف الى صفوف تحته بالعدد المطلوب
'وقبل النسخ يتم مسح البيانات القديمه
'تاريخ الانشاء 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
يعني مثلا الصفحه الاولى والتانيه تبدا من الصف التاسع..
والصفحه التالته من الصف السابع..
والرابعه من الصف الثامن .. يعني بدايات مختلفه جزاكم الله خيرا
أفضل إجابة مقدمة من
YasserKhalil
وهي:
تفضل الكود بعد الدمج
عرض الإجابة
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
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")
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
أعجبني أعجبك هذاإلغ اعجابي 0
- توقيع :ناصر سعيد
-
جزاكم الله خيرا
