ناصر سعيد

ملف التطبيق http://www.mediafire.com/file/yr1rrb7... ============================== http://gulfup.co/itpyj0db0zzp ================================ رابط اخر https://up.top4top.net/downloadf-644qz4ck1-rar.html ================= Sub sajida() '=================== 'هذا الكود للنابغه ساجدة العزاوي 'الهدف من الكود هو استخراج وطباعه شهادات الناجحين 'كل 4 شهادات في صفحه واحده 'تم هذا الكود في 6/10/2017 '=*=*=*=*=*=*=* Dim SHehada As Worksheet, DATA As Worksheet, Z As Range Set DATA = Worksheets("رصد الترم الثانى") 'اسم شيت قاعدة البيانات Set SHehada = Worksheets("4شهادات") 'اسم الشيت الخاص بالشهادات Dim myArray, targt targt = "ناج*" 'خلية البحث Set Z = SHehada.Range("M3") '=================== c = 0 Application.ScreenUpdating = False lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row 'اخر صف به بيانات ' عدد الصفوف الخارجة عن التوزيع في ورقة مصدر البيانات For i = 7 To lr '======= If DATA.Cells(i, 101) Like targt & "*" And c = 0 Then ' If (DATA.Cells(i, 101) = "ناجــــح" Or DATA.Cells(i, 101) = "ناجحــــة") And c = 0 Then Z = DATA.Cells(i, 2) c = c + 1 '=== ' ElseIf (DATA.Cells(i, 101) Like "*" & "ناج" & "*" And c = 1 Then ElseIf DATA.Cells(i, 101) Like targt & "*" And c = 1 Then SHehada.Range("M19") = DATA.Cells(i, 2) c = c + 1 ' ElseIf (DATA.Cells(i, 101) = "ناجــــح" Or DATA.Cells(i, 101) = "ناجحــــة") And c = 2 Then ElseIf DATA.Cells(i, 101) Like targt & "*" And c = 2 Then SHehada.Range("M35") = DATA.Cells(i, 2) c = c + 1 ' ElseIf (DATA.Cells(i, 101) = "ناجــــح" Or DATA.Cells(i, 101) = "ناجحــــة") And c = 3 Then ElseIf DATA.Cells(i, 101) Like targt & "*" And c = 3 Then SHehada.Range("M51") = DATA.Cells(i, 2) c = c + 1 End If If i = lr And c = 4 Then SHehada.Range("a1:p63").PrintOut: Exit For If i = lr And c = 3 Then SHehada.Range("a1:p47").PrintOut: Exit For If i = lr And c = 2 Then SHehada.Range("a1:p31").PrintOut: Exit For If i = lr And c = 1 Then SHehada.Range("a1:p15").PrintOut: Exit For If i < lr And (SHehada.Range("M19") = "" Or SHehada.Range("M35") = "" Or SHehada.Range("M51") = "") Then GoTo 1 If i < lr And c = 4 Then SHehada.Range("a1:p63").PrintOut c = 0 Z = "" SHehada.Range("M19") = "" SHehada.Range("M35") = "" SHehada.Range("M51") = "" 1: Next i Z = "" SHehada.Range("M19") = "" SHehada.Range("M35") = "" SHehada.Range("M51") = "" Application.ScreenUpdating = True End Sub '=*=*=**=*=*=*=*=*

الله يسعد ايامكم وايامنا يارب هذا هو الملف وهذا هو الكود Sub sajida() '=================== 'هذا الكود للنابغه ساجدة العزاوي 'الهدف من الكود هو استخراج وطباعه شهادات الناجحين 'كل 4 شهادات في صفحه واحده 'تم هذا الكود في 6/10/2017 '=*=*=*=*=*=*=* Dim SHehada As Worksheet, DATA As Worksheet, Z As Range Set DATA = Worksheets("رصد الترم الثانى") 'اسم شيت قاعدة البيانات Set SHehada = Worksheets("4شهادات") 'اسم الشيت الخاص بالشهادات Dim myArray, targt targt = "ناج*" 'خلية البحث Set Z = SHehada.Range("M3") '=================== c = 0 Application.ScreenUpdating = False lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row 'اخر صف به بيانات ' عدد الصفوف الخارجة عن التوزيع في ورقة مصدر البيانات For i = 7 To lr '======= If DATA.Cells(i, 101) Like targt & "*" And c = 0 Then ' If (DATA.Cells(i, 101) = "ناجــــح" Or DATA.Cells(i, 101) = "ناجحــــة") And c = 0 Then Z = DATA.Cells(i, 2) c = c + 1 '=== ' ElseIf (DATA.Cells(i, 101) Like "*" & "ناج" & "*" And c = 1 Then ElseIf DATA.Cells(i, 101) Like targt & "*" And c = 1 Then SHehada.Range("M19") = DATA.Cells(i, 2) c = c + 1 ' ElseIf (DATA.Cells(i, 101) = "ناجــــح" Or DATA.Cells(i, 101) = "ناجحــــة") And c = 2 Then ElseIf DATA.Cells(i, 101) Like targt & "*" And c = 2 Then SHehada.Range("M35") = DATA.Cells(i, 2) c = c + 1 ' ElseIf (DATA.Cells(i, 101) = "ناجــــح" Or DATA.Cells(i, 101) = "ناجحــــة") And c = 3 Then ElseIf DATA.Cells(i, 101) Like targt & "*" And c = 3 Then SHehada.Range("M51") = DATA.Cells(i, 2) c = c + 1 End If If i = lr And c = 4 Then SHehada.Range("a1:p63").PrintOut: Exit For If i = lr And c = 3 Then SHehada.Range("a1:p47").PrintOut: Exit For If i = lr And c = 2 Then SHehada.Range("a1:p31").PrintOut: Exit For If i = lr And c = 1 Then SHehada.Range("a1:p15").PrintOut: Exit For If i < lr And (SHehada.Range("M19") = "" Or SHehada.Range("M35") = "" Or SHehada.Range("M51") = "") Then GoTo 1 If i < lr And c = 4 Then SHehada.Range("a1:p63").PrintOut c = 0 Z = "" SHehada.Range("M19") = "" SHehada.Range("M35") = "" SHehada.Range("M51") = "" 1: Next i Z = "" SHehada.Range("M19") = "" SHehada.Range("M35") = "" SHehada.Range("M51") = "" Application.ScreenUpdating = True End Sub '=*=*=**=*=*=*=*=* ================================ http://gulfup.co/itpyj0db0zzp ================================ رابط اخر https://up.top4top.net/downloadf-644qz4ck1-rar.html

استاذ ياسر خليل السلام عليكم ورحمة الله وبركاته جزاك الله خيرا وبارك فيك .. آمين يارب العالمين وبعد : Sub القيم_الفريده() 'هذا الكود تم بواسطه المحترم ياسر خليل 'الهدف من الكود 'الاتيان بالقيم الفريده لبيانات في عمود 'تم في 31/8/2017 Dim rng As Range Dim a As Variant Dim ws As Worksheet 'اسم الخليه في صفحه الهدف ' التي ستظهر بها القيم القريده Const strTRng As String = "D4" 'في صفحه الهدف العمود المطلوب ' وضع القيم الفريده فيه Const strHRng As String = "D4:D1000" 'في صفحه المصدر العمود المطلوب ' استخراج القيم الفريده منه Const strSRng As String = "C10:C200" 'اسم الشيت في صفحه المصدر Const str As String = "Sheet1" Set ws = Sheets(str) '====================== 'نفترض وجود بيانات كأسماء في النطاق المذكور Set rng = ws.Range(strSRng) ActiveSheet.Range(strHRng).ClearContents 'تخزين النتائج في مصفوفة a = GetDistinct(rng) 'النطاق المطلوب وضع النتائج للأسماء الغير مكررة فيه ActiveSheet.Range(strTRng).Resize(UBound(a, 1) + 1) = Application.Transpose(a) 'فرز العمود المنقول اليه القيم الفريده [D4:D200].Sort [D4], xlAscending 'عمود القيم الفريده ستتم عليه بعض التنسيقات With ActiveSheet.Range(strHRng) 'تنسيق العمود تكست .EntireColumn.NumberFormat = "@" .Font.Bold = True .ReadingOrder = xlRTL: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With End Sub Function GetDistinct(ByVal oTarget As Range) As Variant Dim dic As Object Dim vArr As Variant Dim v As Variant Set dic = CreateObject("Scripting.Dictionary") vArr = oTarget For Each v In vArr If Not IsEmpty(v) Then dic(v) = v Next v GetDistinct = dic.Items() End Function ================ منقول للافاده من http://excel-egy.com/forum/t68&count=12

استاذ ياسر خليل السلام عليكم ورحمة الله وبركاته جزاك الله خيرا وبارك فيك .. آمين يارب العالمين وبعد : Sub القيم_الفريده() 'هذا الكود تم بواسطه المحترم ياسر خليل 'الهدف من الكود 'الاتيان بالقيم الفريده لبيانات في عمود 'تم في 31/8/2017 Dim rng As Range Dim a As Variant Dim ws As Worksheet 'اسم الخليه في صفحه الهدف ' التي ستظهر بها القيم القريده Const strTRng As String = "D4" 'في صفحه الهدف العمود المطلوب ' وضع القيم الفريده فيه Const strHRng As String = "D4:D1000" 'في صفحه المصدر العمود المطلوب ' استخراج القيم الفريده منه Const strSRng As String = "C10:C200" 'اسم الشيت في صفحه المصدر Const str As String = "Sheet1" Set ws = Sheets(str) '====================== 'نفترض وجود بيانات كأسماء في النطاق المذكور Set rng = ws.Range(strSRng) ActiveSheet.Range(strHRng).ClearContents 'تخزين النتائج في مصفوفة a = GetDistinct(rng) 'النطاق المطلوب وضع النتائج للأسماء الغير مكررة فيه ActiveSheet.Range(strTRng).Resize(UBound(a, 1) + 1) = Application.Transpose(a) 'فرز العمود المنقول اليه القيم الفريده [D4:D200].Sort [D4], xlAscending 'عمود القيم الفريده ستتم عليه بعض التنسيقات With ActiveSheet.Range(strHRng) 'تنسيق العمود تكست .EntireColumn.NumberFormat = "@" .Font.Bold = True .ReadingOrder = xlRTL: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With End Sub Function GetDistinct(ByVal oTarget As Range) As Variant Dim dic As Object Dim vArr As Variant Dim v As Variant Set dic = CreateObject("Scripting.Dictionary") vArr = oTarget For Each v In vArr If Not IsEmpty(v) Then dic(v) = v Next v GetDistinct = dic.Items() End Function ================ منقول للافاده

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

وبارك فيك ربنا الموضوع منقول من منتدى http://excel-egy.com/forum/t67

الموضوع خاص بالاستاذ زيزو العجوز .. حفظه الله السلام عليكم ورحمة الله البحث عن اسم من خلال قائمة طويلة من الاسماء باستخدام يوزر فورم مكون من تكست بوكس وليست بوكس اليكم الملف اتمنى ان يعجبكم '=========================== '=========================== Option Explicit 'الكود للاستاذ زيزو العجوز 'وتمت الاضافه عليه من قبل الاستاذ ياسر خليل 'الهدف من الكود البحث باول حرف Private Sub TextBox1_Change() Dim a As Variant Dim b() As Variant Dim i As Long Dim j As Long ListBox1.Clear a = Sheet1.Range("B2:B" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row).Value For i = LBound(a, 1) To UBound(a, 1) If TextBox1.Value = Left(a(i, 1), Len(TextBox1.Value)) Then j = j + 1 ReDim Preserve b(1 To j) b(j) = a(i, 1) End If Next i On Error Resume Next ListBox1.List = b On Error GoTo 0 End Sub Private Sub UserForm_Activate() TextBox1.SetFocus End Sub Private Sub CommandButton1_Click() Unload Me End Sub Private Sub ListBox1_Click() Dim ws As Worksheet Dim r As Variant TextBox1.Value = ListBox1.Value Set ws = Sheets("DATA") 'هنا يتم البحث عن قيمة التكست بوكس في العمود الثاني r = Application.Match(TextBox1.Value, ws.Columns(2), 0) 'في حالة كانت النتيجة رقمية يعني أنه تم العثور على اسم الشخص المطلوب If IsNumeric(r) Then 'في هذه الحالة يتم تحديد الخلية في العمود الثاني في الصف الذي تم العثور عليه ws.Cells(r, 2).Select End If End Sub ============================ بحث باول حرف.rar

ملف به كودين رائعين للمحترم الاستاذ ياسر خليل حفظه الله ورعاه كود لنسخ الصفوف بمسح البيانات القديمه والكود الاخر بدون مسح البيانات القديمه لاضافه طالب محول بعد الطلاب نسـخ صفوف في صفحات مختلفه 11.rar ================================== Option Explicit 'هذا الكود للمحترم ياسر خليل ' الهدف من الكود نسخ صفوف بالعدد في يدايات مختلفه من صفحات مختلفه 'يعمل الكود بدون مسح بيانات الطلاب القديمه 'يعمل الكود في بدايات صفوف مختلفه في صفحات متعدده 'تم هذا الكود في 25/8/2017 Sub CopyRow_Procedure() CopyRow "بيانات الطلبة", 9 CopyRow "رصد الترم الثانى", 10 CopyRow "كنترول شيت", 10 CopyRow "الحاله", 11 CopyRow "كشف ناجح", 9 CopyRow "أعمال السنة", 7 CopyRow "تحريرى ف 2", 7 CopyRow "إنجاز1", 7 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) If ws Is Nothing Then MsgBox "Sheet " & sSheet & " Doesn't Exists In The Workbook.", vbExclamation, "Sheet Not Found!" Exit Sub End If On Error GoTo 0 i = Sheets("بيانات الطلبة").Range("Q1").Value - 1 lc = LastRowColumn(ws, "C") lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 On Error GoTo Skipper ws.Range(ws.Cells(sRow, 1), ws.Cells(sRow, lc)).Copy ws.Range("A" & lr).Resize(i + 1).PasteSpecial xlPasteAll ws.Range("A" & lr).Resize(i + 1, lc).SpecialCells(xlCellTypeConstants, 3).ClearContents Skipper: 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 الملف به الكودين .. دعاء لله ان يرحمنا جميعا ويرحم الاموات نسـخ صفوف في صفحات مختلفه 11.rar

ملف به الكودين الرائعين للمحترم الاستاذ ياسر خليل حفظه الله ورعاه كود لنسخ الصفوف بمسح البيانات القديمه والكود الاخر بدون مسح البيانات القديمه لاضافه طالب محول بعد الطلاب نسـخ صفوف في صفحات مختلفه 11.rar ================================== Option Explicit 'هذا الكود للمحترم ياسر خليل ' الهدف من الكود نسخ صفوف بالعدد في يدايات مختلفه من صفحات مختلفه 'يعمل الكود بدون مسح بيانات الطلاب القديمه 'يعمل الكود في بدايات صفوف مختلفه في صفحات متعدده 'تم هذا الكود في 25/8/2017 Sub CopyRow_Procedure() CopyRow "بيانات الطلبة", 9 CopyRow "رصد الترم الثانى", 10 CopyRow "كنترول شيت", 10 CopyRow "الحاله", 11 CopyRow "كشف ناجح", 9 CopyRow "أعمال السنة", 7 CopyRow "تحريرى ف 2", 7 CopyRow "إنجاز1", 7 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) If ws Is Nothing Then MsgBox "Sheet " & sSheet & " Doesn't Exists In The Workbook.", vbExclamation, "Sheet Not Found!" Exit Sub End If On Error GoTo 0 i = Sheets("بيانات الطلبة").Range("Q1").Value - 1 lc = LastRowColumn(ws, "C") lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 On Error GoTo Skipper ws.Range(ws.Cells(sRow, 1), ws.Cells(sRow, lc)).Copy ws.Range("A" & lr).Resize(i + 1).PasteSpecial xlPasteAll ws.Range("A" & lr).Resize(i + 1, lc).SpecialCells(xlCellTypeConstants, 3).ClearContents Skipper: 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 الملف به الكودين .. دعاء لله ان يرحمنا جميعا ويرحم الاموات نسـخ صفوف في صفحات مختلفه 11.rar

===================== تم نشره في 24‏/08‏/2017 طباعة شهادات الناجحين والراسبين 2 طباعة شهادتين بورقة واحدة ساجدة العزاوي قناة ساجدة العزاوي التعليمية print excel vba طباعة شهادات الطلاب طباعة تقدير الطلاب sajida alazzawi رابط ملف التطبيق http://www.mediafire.com/file/434sjdj... رابط صفحة الفيس بوك https://www.facebook.com/sajidaalazza...

الكود في حلته النهائيه يحفظ الله الاستاذ الخلوق ياسر خليل صاحب هذا الكود الرائع ويحفظ الله كل من كانت له بصمه في اخراج هذا العمل ويرحم امواتنا الكود مهم جدا لرجال التربيه والتعليم ( الكنترولات ) لتخفيف حجم البرنامج ليعمل على عدد الطلاب فقط مهما كان عددهم وينسخ المعدلات يعني ماعليك الا ان تضع معادلاتك في الصف الذي يلي العنوان فقط والكود ينسخها بالعدد .. حقا رائع '================== 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

اشكر كل من واساني في وفاه اخي الحبيب واسال الله العلي القدير ان يجزيه خيرا .. يارب

الكود في حلته النهائيه يحفظ الله الاستاذ الخلوق ياسر خليل صاحب هذا الكود الرائع ويحفظ الله كل من كانت له بصمه في اخراج هذا العمل ويرحم امواتنا الكود مهم جدا لرجال التربيه والتعليم ( الكنترولات ) لتخفيف حجم البرنامج ليعمل على عدد الطلاب فقط مهما كان عددهم وينسخ المعدلات يعني ماعليك الا ان تضع معادلاتك في الصف الذي يلي العنوان فقط والكود ينسخها بالعدد .. حقا رائع '================== 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

ربنا يحفظكم ويبارك فيكم لجميع من واساني

هذا هو الكود الذي هداني به المحترم الاستاذ بن عليه حفظه الله ورعاه وهو خاص بنسخ صفوف اسفل الصفوف المنسوخه 'هذا الكود للمحترم ياسر العربي ' الهدف من الكود هو نسخ صف الى صفوف تحته بالعدد المطلوب 'بدون مسح البيانات القديمه 'تاريخ الانشاء 30/7/2017 'تم التعديل بواسطه المحترم الخلوق بن عليه حاجي '=*=*=*=*=*=*=*=*=*=*=*=*=*=* Private Sub CommandButton1_Click() Dim sh As Worksheet, lr As Long, str As String If TextBox1.Text = Sheets("بيانات الطلبة").Range("F1") Then Me.Hide TextBox1.Text = "" MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'اذا كان عدد المتقدمين اقل من اتنين يتم ايقاف الكود ولا يكمل If Sheets("بيانات الطلبة").Range("Q1") < 2 Then Exit Sub End If '=*=*=*=*=*=* For Each sh In Sheets(Array("بيانات الطلبة", "إنجاز1", "تحريرى ف 1", "تحريرى ف 2", "أعمال السنة", "كشف ناجح", "الحاله", "كنترول شيت", "رصد الترم الثانى", "كنترول شيت (2)", "رصد الترم الأول", "كشف الدور الثاني")) '--------------------------------------------------------------------------------------- 'lr = sh.Range("B" & sh.Range("b10000").End(xlUp).Row).Row lr = sh.Range("A" & sh.Range("A10000").End(xlUp).Row).Row '--------------------------------------------------------------------------------------- sh.Activate '======================== ' str المتغير دا يتم تخزين اسم العمود الاخير فيه للعمل عليه 'يتم الذهاب الى اخر عمود بالاعتماد على الصف السادس ويتم استخلاص اسم العمود من اسم النطاق str = Split(sh.Range("HH9").End(xlToLeft).Address, "$")(1) ' نسخ الصف السابع لكل شيت من حيث عدد الاعمدة الى العدد المحدد بعدد المتقدمين '--------------------------------------------------------------------------------------- Set Rng = Range("A" & lr + IIf(lr = 9, 0, 1) & ":" & str & ['بيانات الطلبة'!Q1] + lr - IIf(lr = 9, 1, 0)) sh.Range("A9:" & str & 9).Copy Destination:=Rng '--------------------------------------------------------------------------------------- Next Sheets("بيانات الطلبة").Select Range("A4").Select Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Unload Me Else MsgBox "عفوا كلمة المرور خاطئة و لن يتم تنفيذ المطلوب" TextBox1.Text = "" TextBox1.SetFocus End If End Sub Private Sub UserForm_Click() End Sub '===================================

شرح عمل الشهادات للنابغه ساجده العزاوي ================= رابط ملف التطبيق http://www.mediafire.com/file/jdte1oy

للرفع لننهي الاعمال على خير ان شاء الله

بسم الله الرحمن الرحيم احبابنا في الله كم كنت اتمنى ان يستمر عطائي لكم بان اجمع واهذب الاكواد التي اعتبرها كنوز لرجالات التربيه والتعليم ولكن انتقل اخي الحبيب الاستاذ الجليل سعيد .. الى رحاب الله فتغيرت الدنيا معي ولهذا قررت ان اختم اعمالي في هذا المنتدى الراق باهله بهذا العمل واجعله رحمة ونورا لاخي واطلب منكم ان تدعو لاخي بالرحمة والمغره وان يسكنه الله فسيح جناته .. باخلاص فسياتي وقت نكون نحن فيه احوج الى هذا الدعاء ساكمل ان شاء الله في وقت اخر لظروف خارجه عن ارادتي

للرفع رفع الله مقداركم

اكواد رائعه خاصه بعمل الكنترول في ملف اكواد رائعه.rar

المرفق النهائي الذي ينسخ الصفوف بالعدد في عده صفحات مختلفه من ملف بسهوله ويسر وذلك بعد مسح البيانات القديمه وهو طبعا لخليفه العلامه عبد الله باقشير المحترم ياسر العربي وتعديل العبقري ياسر خليل وسبب التعديل ادخال جزئيه جديده لعمليه مسح البيانات القديمه نسخ 1صفوف.rar وهذا هو الكود المرفق بالملف لمن اراد الاستمتاع بالكنوز 'هذا الكود للمحترم ياسر العربي ' الهدف من الكود هو نسخ صف الى صفوف تحته بالعدد المطلوب 'وقبل النسخ يتم مسح البيانات القديمه 'تاريخ الانشاء 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("C2").Value If TextBox1.Text = ws.Range("F1") Then Me.Hide TextBox1.Text = "" MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب", 64 Application.ScreenUpdating = False Application.Calculation = xlManual 'اذا كان عدد المتقدمين اقل من اتنين يتم ايقاف الكود ولا يكمل If ws.Range("C2") < 2 Then Exit Sub End If For Each sh In Sheets(Array("بيانات الطلبة", "إنجاز1", "تحريرى ف 1", "تحريرى ف 2", "أعمال السنة", "كشف الدور الثاني", "رصد الترم الثانى", "كشف ناجح")) lr = IIf(LastOccupiedRowNum(sh) = 7, 7, LastOccupiedRowNum(sh)) lc = LastOccupiedColNum(sh) 'حذف البيانات الموجودة في النطاق المحدد sh.Range("A8").Resize(Rows.Count - 7, lc).Clear 'نسخ الصف السابع لكل شيت من حيث عدد الاعمدة الى العدد المحدد بعدد المتقدمين sh.Range("A7").Resize(1, lc).AutoFill Destination:=sh.Range("A7").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 جزى الله كل من كان له بصمه في اخراج هذا العمل الى النور

هذا هو المرفق النهائي الذي ينسخ الصفوف بالعدد في عده صفحات مختلفه من ملف بسهوله ويس وذلك بعد مسح البيانات القديمه وهو طبعا لخليفه العلامه عبد الله باقشير المحترم ياسر العربي وتعديل العبقري ياسر خليل وسبب التعديل ادخال جزئيه جديده لعمليه مسح البيانات القديمه نسخ 1صفوف.rar وهذا هو الكود المرفق بالملفلمن اراد الاستمتاع بالكنوز 'هذا الكود للمحترم ياسر العربي ' الهدف من الكود هو نسخ صف الى صفوف تحته بالعدد المطلوب 'وقبل النسخ يتم مسح البيانات القديمه 'تاريخ الانشاء 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("C2").Value If TextBox1.Text = ws.Range("F1") Then Me.Hide TextBox1.Text = "" MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب", 64 Application.ScreenUpdating = False Application.Calculation = xlManual 'اذا كان عدد المتقدمين اقل من اتنين يتم ايقاف الكود ولا يكمل If ws.Range("C2") < 2 Then Exit Sub End If For Each sh In Sheets(Array("بيانات الطلبة", "إنجاز1", "تحريرى ف 1", "تحريرى ف 2", "أعمال السنة", "كشف الدور الثاني", "رصد الترم الثانى", "كشف ناجح")) lr = IIf(LastOccupiedRowNum(sh) = 7, 7, LastOccupiedRowNum(sh)) lc = LastOccupiedColNum(sh) 'حذف البيانات الموجودة في النطاق المحدد sh.Range("A8").Resize(Rows.Count - 7, lc).Clear 'نسخ الصف السابع لكل شيت من حيث عدد الاعمدة الى العدد المحدد بعدد المتقدمين sh.Range("A7").Resize(1, lc).AutoFill Destination:=sh.Range("A7").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 نريد شرح لهم من فضلكم

جزاك الله خيرا .. جاري تضييط الملف النهائي ليكون مرجعا لمن اراده

الطلب مختلف تماما لان الكود الاول خاص بالمسح ثم اضافه صفوف اما هذا الموضوع خاص باضافه صف او صفوف بدون مسح ماتم نسخه من صفوف وكما ذكرت لان طالب محول جاء الى المدرسه فمطلوب اضافته وليس مسح ماسبق من بيانات الطلاب

نريد احد الكرام يشرح ماتيسر له من الاسطر في الكود