asdhamdey

هذا هو المرفق الشيت.rar الذي نريد تطبيق الكود عليه

Sub ناجحين() Dim c As Range For Each c In Sheet1.Range("case") If c.Value = "ناجح" Then Z = Z + 1 lstrow = Sheet2.Range("b20000").End(xlUp).Row + 1 Sheet2.Range(Sheet2.Cells(lstrow, "b"), Sheet2.Cells(lstrow, "ag")) = _ Sheet1.Range(Sheet1.Cells(c.Row, "b"), Sheet1.Cells(c.Row, "ag")).Value Sheet2.Cells(lstrow, "a") = Z: End If Next c End Sub المحترم استاذ ابو عبد الباري لو تكرمت نريد شرحه

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

=IF(B5="";"";IF(AND((COUNTIFS(C5:AX5;"غائب")=0);(COUNTIFS(C5:AX5;"دون المستوى")=0));"ناجح";"راسب")) انظر الى المعادلة (هذا العمل للمحترم الاستاذ محمد ابو البراء ) لو لاحظنا في هذه الدالة سنجد ان االدالة ليس فيها الا نطاق واحد متكرر مرتان وهو c5:ax5 هذا النطاق هو نطاق اول طالب فيه تقديراته من اول مادة الى اخر مادة فبالتالي اذا اردنا استخدامها نستطيع وبسهولة وكل ما علينا الا تغيير هذا النطاق ليتناسب مع عدد موادنا دالة بطريقة جديدة لمعرفة حالة الطالب _راسب او ناجح. =IF(B5="";"";IF(COUNTIF(C5:AX5;"غائب")+COUNTIF(C5:AX5;"دون المستوى")=0;"ناجح";"راسب")) للاستاذ المحترم جمال عبد السميع دالة بطريقة جديدة لمعرفة حالة الطالب _راسب او ناجح. ====================================================== ====================================================== شرط النجاح للطالب ان يكون حاصل علة 30% من درجه امتحان اخر العام ان يكون الطالب حاصل على نصف او اكبر من نصف درجة المجموع لنفس الماده لايكون غائب في امتحان اخر العام لنفس الماده abo_abary_Book1.ra =IF(OR(H13<$H$10;H13="غ";I13<$I$10);"راسبة";"ناجحة")

=IF(OR(H13<$H$10;H13="غ";I13<$I$10);"راسبة";"ناجحة") تمام التمام حفظك الله استاذ ابو عبد الباري

بارك الله في حضرتك وجعل الله جميع أعمالك في موازين حسناتك ...

بارك الله في حضرتك وجعل الله جميع أعمالك في موازين حسناتك ...

بارك الله في حضرتك وجعل الله جميع أعمالك في موازين حسناتك ...

بارك الله فيكم

Option Explicit Sub UniqueSortedList() Dim Arr, X As Object Application.ScreenUpdating = False With CreateObject("System.Collections.ArrayList") Set X = .Clone: X.Add " " Sheets("بيانات الطلبة").Activate For Each Arr In Sheets("بيانات الطلبة").Range("V7", Range("V" & Rows.Count).End(xlUp)).Value If Arr <> "" Then If IsNumeric(Arr) Then If Not .Contains(Arr) Then .Add Arr Else If Not X.Contains(Arr) Then X.Add CStr(Arr) End If End If Next .Sort: X.Sort: .addRange X: Arr = Join(.ToArray, ",") End With Sheets("الاوائل").Activate With Sheets("الاوائل").Range("S7").Validation .Delete .Add xlValidateList, 1, 1, Arr End With Application.ScreenUpdating = True End Sub كود قائمه متسدله بون تكرار ومرتبه تصاعديا للاستاذ المحترم ياسر خليل قائمه منسدلة ديناميكية مطاطية بدون تكرار اى بند فيها Unique Sorted Validation List.rar

Sub Tarhil_Ragab() 'تعريف المتغيرات Dim Sh As Worksheet Dim strSh As String Dim I As Long Dim AA As Long 'سطر لإيقاف تحديث الشاشة Application.ScreenUpdating = False 'مسح محتويات النطاق في ورقة العمل ناجح Sheets("ناجح").Range("A12:X1000").ClearContents 'مسح محتويات النطاق في ورقة العمل دور ثان Sheets("دور ثان").Range("A12:X1000").ClearContents 'مسح محتويات النطاق في ورقة العمل راسب Sheets("راسب").Range("A12:X1000").ClearContents 'بدء التعامل مع ورقة العمل الأولى التي تعتبر الورقة الرئيسية With Sheet1 '[Y] حلقة تكرارية بدايةً من الصف الـ 12 وحتى آخر صف به بيانات بالاعتماد على العمود For I = 12 To .Cells(10000, "Y").End(xlUp).Row '[Y] تعيين قيمة المتغير ليساوي قيمة الخلية في الصف المحدد في العمود 'ففي أول حلقة تكرارية سيكون الصف هو رقم 12 [I] المقصود بالصف المحدد الصف الذي يحمل قيمة المتغير 'وفي الحلقة التالية سيكون الصف رقم 13 وهكذا مع كل حلقة تكرارية يتغير الصف strSh = .Cells(I, "Y").Value 'تعيين المتغير ليساوي آخر صف في الورقة التي سيتم الترحيل إليها 'أو يمكنك القول معرفة رقم صف أول صف فارغ AA = Sheets(strSh).Cells(10000, 2).End(xlUp).Row + 1 'إذا كان المتغير أقل من 12 الذي من المفترض أنه صف البداية لعمليات الترحيل فإنه يتم تعيين المتغير ليساوي 12 If AA < 12 Then AA = 12 'في حالة حدوث خطأ يتم تجنبه بهذا السطر On Error Resume Next 'نسخ النطاق في الصف المحدد من العمود الثاني إلى العمود الرابع والعشرون .Range(.Cells(I, "B"), .Cells(I, "X")).Copy 'لصق النطاق المنسوخ إلى ورقة العمل المناسبة واللصق يكون لصق قيم فقط Sheets(strSh).Range("B" & AA).PasteSpecial xlPasteValues 'إلغاء خاصية النسخ واللصق Application.CutCopyMode = False 'هذا السطر يقوم بترقيم الصف الذي تم ترحيله في الورقة الهدف 'حيث يعتمد على إنقاص 11 من رقم الصف الحالي 'فإذا كان الصف الحالي هو رقم 12 ألا وهو رقم البداية فإن الرقم 'المسلسل سيكون 12 - 11 أي سيكون الرقم المسلسل 1 Sheets(strSh).Cells(AA, "A").Value = Sheets(strSh).Cells(AA, "A").Row - 11 'الانتقال للصف التالي في الحلقة التكرارية Next I 'حلقة تكرارية لكل أوراق العمل لتحديد الخلية الأولى في ورقةالعمل For Each Sh In ThisWorkbook.Worksheets Application.Goto Sh.Range("A1") Next Sh 'تنشيط ورقة العمل الأولى .Activate 'انتهاء التعامل مع ورقة العمل الأولى End With 'سطر لإعادة تفعيل اهتزاز الشاشة Application.ScreenUpdating = True 'إظهار رسالة تفيد بانتهاء عمل الكود MsgBox "تم الفصل بنجاح", 64 End Sub

Sub Tarhil_Ragab() 'تعريف المتغيرات Dim Sh As Worksheet Dim strSh As String Dim I As Long Dim AA As Long 'سطر لإيقاف تحديث الشاشة Application.ScreenUpdating = False 'مسح محتويات النطاق في ورقة العمل ناجح Sheets("ناجح").Range("A12:X1000").ClearContents 'مسح محتويات النطاق في ورقة العمل دور ثان Sheets("دور ثان").Range("A12:X1000").ClearContents 'مسح محتويات النطاق في ورقة العمل راسب Sheets("راسب").Range("A12:X1000").ClearContents 'بدء التعامل مع ورقة العمل الأولى التي تعتبر الورقة الرئيسية With Sheet1 '[Y] حلقة تكرارية بدايةً من الصف الـ 12 وحتى آخر صف به بيانات بالاعتماد على العمود For I = 12 To .Cells(10000, "Y").End(xlUp).Row '[Y] تعيين قيمة المتغير ليساوي قيمة الخلية في الصف المحدد في العمود 'ففي أول حلقة تكرارية سيكون الصف هو رقم 12 [I] المقصود بالصف المحدد الصف الذي يحمل قيمة المتغير 'وفي الحلقة التالية سيكون الصف رقم 13 وهكذا مع كل حلقة تكرارية يتغير الصف strSh = .Cells(I, "Y").Value 'تعيين المتغير ليساوي آخر صف في الورقة التي سيتم الترحيل إليها 'أو يمكنك القول معرفة رقم صف أول صف فارغ AA = Sheets(strSh).Cells(10000, 2).End(xlUp).Row + 1 'إذا كان المتغير أقل من 12 الذي من المفترض أنه صف البداية لعمليات الترحيل فإنه يتم تعيين المتغير ليساوي 12 If AA < 12 Then AA = 12 'في حالة حدوث خطأ يتم تجنبه بهذا السطر On Error Resume Next 'نسخ النطاق في الصف المحدد من العمود الثاني إلى العمود الرابع والعشرون .Range(.Cells(I, "B"), .Cells(I, "X")).Copy 'لصق النطاق المنسوخ إلى ورقة العمل المناسبة واللصق يكون لصق قيم فقط Sheets(strSh).Range("B" & AA).PasteSpecial xlPasteValues 'إلغاء خاصية النسخ واللصق Application.CutCopyMode = False 'هذا السطر يقوم بترقيم الصف الذي تم ترحيله في الورقة الهدف 'حيث يعتمد على إنقاص 11 من رقم الصف الحالي 'فإذا كان الصف الحالي هو رقم 12 ألا وهو رقم البداية فإن الرقم 'المسلسل سيكون 12 - 11 أي سيكون الرقم المسلسل 1 Sheets(strSh).Cells(AA, "A").Value = Sheets(strSh).Cells(AA, "A").Row - 11 'الانتقال للصف التالي في الحلقة التكرارية Next I 'حلقة تكرارية لكل أوراق العمل لتحديد الخلية الأولى في ورقةالعمل For Each Sh In ThisWorkbook.Worksheets Application.Goto Sh.Range("A1") Next Sh 'تنشيط ورقة العمل الأولى .Activate 'انتهاء التعامل مع ورقة العمل الأولى End With 'سطر لإعادة تفعيل اهتزاز الشاشة Application.ScreenUpdating = True 'إظهار رسالة تفيد بانتهاء عمل الكود MsgBox "تم الفصل بنجاح", 64 End Sub

Sub printpreview1() 'كود معاينة طباعة مطاطي Range("a4:aa" & Cells(Rows.count, "c").End(xlUp).Row).printpreview End Sub Sub print_2() 'كود طباعة مطاطي Range("a4:aa" & Cells(Rows.count, "c").End(xlUp).Row).PrintOut End Sub كود معاينه طباعة مطاطي وكود طباعة مطاطي

من باب تجميع الاعمال التي تهم المدرسين في مكان واحد Sub Filter() Dim LR As Long With ورقة1 LR = .Cells(.Rows.Count, "D").End(xlUp).Row .Range("c5:y5" & LR).AdvancedFilter xlFilterCopy, Range("aa1:aa2"), Range("c5:y5") End With Range("a1").Select LR = Cells(Rows.Count, "D").End(xlUp).Row ActiveSheet.PageSetup.PrintArea = Range("b2:y" & LR).Address End Sub شرح-كود-الفلتر. Sub kh_Filter() ''''' Dim LR As Long With Sheet2 'يمسح منطقة اخراج البيانات قبل الفلتره من بداية السطر 9 حتي نهاية ترقيم الورقة .Range(.Cells(9, 1), .Cells(Rows.Count, Columns.Count)).ClearContents End With With Sheet1 'لتحديد رقم اخر صف في قاعدة البيانات LR = .Cells(.Rows.Count, "AF").End(xlUp).Row 'كود للتصفية المتقدمة يحدد فيه مدي قاعدة البيانات ومنطقة مدي شروط التصفية وايضا مدي مخرجات ناتج التصفية .Range("AD6:BH" & LR).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheet2.Range("A1:A2"), CopyToRange:=Sheet2.Range("C9"), Unique:=True End With Range("a3").Select 'لتحديد رقم اخر صف في مدي المخرجات LR = Cells(Rows.Count, "AF").End(xlUp).Row 'يقوم بتحديد مدي منطقة طباعه المخرجات ActiveSheet.PageSetup.PrintArea = Range("b2:AB" & LR).Address End Sub وضعت شرح العملاق عمر الحسيني مع الكود كود فلتره 10. Sub mh() ' ' ماكرو2 ماكرو ' الماكرو مسجل ‎17/06/2016 بواسطة ‎11 ' ' Range("A3:D47").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _ "f2:f3"), CopyToRange:=Range("H4:K4"), Unique:=False End Sub كود فلتره في نقس الصعحه _الطلبة الضعاف.

شكرا استاذ ياسر العربي استاذ كعبلاوي شرط النجاح للطالب ان يكون حاصل علة 30% من درجه امتحان اخر العام ان يكون الطالب حاصل على نصف او اكبر من نصف درجة المجموع لنفس الماده لايكون غائب في امتحان اخر العام لنفس الماده شكرا

جزاك الله خيرا وادخلك الجنه من اوسع ابوابها

جزاك الله خيرا وادخلك الجنه من اوسع ابوابها

جزاك الله خيرا استاذ حسامي وادخلك الجنه من اوسع ابوابها

Public Sub Sheetpasswordremover() Dim Mess As String, Header As String Dim Credit As String Dim RepBack As String, AllClear As String Dim PWord1 As String Dim ShTag As Boolean, WinTag As Boolean Dim w1 As Worksheet, w2 As Worksheet Dim i As Integer, j As Integer, k As Integer, l As Integer Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer Application.ScreenUpdating = False Header = "فك تشفير صفحات الإكسل" Credit = vbNewLine & vbNewLine & "منتديات أوفيسنا التعليمية" RepBack = vbNewLine & vbNewLine & "www.officena.com" With ActiveWorkbook WinTag = .ProtectStructure Or .ProtectWindows End With ShTag = False For Each w1 In Worksheets ShTag = ShTag Or w1.ProtectContents Next w1 If Not ShTag And Not WinTag Then Mess = vbNewLine & "لا يوجد كلمة سر للصفحات الحالية" & vbNewLine & Credit MsgBox Mess, vbInformation, Header Exit Sub End If Mess = "سوف تستغرق عملية فك الحماية ثواني معدودة" & _ vbNewLine & "OK إضغط " & vbNewLine & "وإنتظر حتى يتم فك الحماية " & vbNewLine & _ Credit MsgBox Mess, vbInformation, Header If Not WinTag Then Mess = "" & _ "" & vbNewLine & _ "جاري حذف الحماية " & _ Credit MsgBox Mess, vbInformation, Header Else On Error Resume Next Do For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 With ActiveWorkbook .Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If .ProtectStructure = False And _ .ProtectWindows = False Then PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Mess = "You had a Worksheet Structure or " & vbNewLine & _ Credit MsgBox Mess, vbInformation, Header Exit Do End If End With Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next Loop Until True On Error GoTo 0 End If If WinTag And Not ShTag Then Mess = "Only structure / windows protected with " & vbNewLine & _ "the password that was just found." & vbNewLine & _ AllClear & Credit & RepBack MsgBox Mess, vbInformation, Header Exit Sub End If On Error Resume Next For Each w1 In Worksheets w1.Unprotect PWord1 Next w1 On Error GoTo 0 ShTag = False For Each w1 In Worksheets ShTag = ShTag Or w1.ProtectContents Next w1 If Not ShTag Then Mess = AllClear & Credit & RepBack MsgBox Mess, vbInformation, Header Exit Sub End If For Each w1 In Worksheets With w1 If .ProtectContents Then On Error Resume Next Do For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 .Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If Not .ProtectContents Then PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Mess = "تم حذف كلمة السر " & _ Credit MsgBox Mess, vbInformation, Header For Each w2 In Worksheets w2.Unprotect PWord1 Next w2 Exit Do End If Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next Loop Until True On Error GoTo 0 End If End With Next w1 Mess = AllClear & Credit & RepBack MsgBox Mess, vbInformation, Header End Sub ربنا يبارك في صاحب هذا العمل .. يارب passwordremover.rar

Public Sub Sheetpasswordremover() Dim Mess As String, Header As String Dim Credit As String Dim RepBack As String, AllClear As String Dim PWord1 As String Dim ShTag As Boolean, WinTag As Boolean Dim w1 As Worksheet, w2 As Worksheet Dim i As Integer, j As Integer, k As Integer, l As Integer Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer Application.ScreenUpdating = False Header = "فك تشفير صفحات الإكسل" Credit = vbNewLine & vbNewLine & "منتديات أوفيسنا التعليمية" RepBack = vbNewLine & vbNewLine & "www.officena.com" With ActiveWorkbook WinTag = .ProtectStructure Or .ProtectWindows End With ShTag = False For Each w1 In Worksheets ShTag = ShTag Or w1.ProtectContents Next w1 If Not ShTag And Not WinTag Then Mess = vbNewLine & "لا يوجد كلمة سر للصفحات الحالية" & vbNewLine & Credit MsgBox Mess, vbInformation, Header Exit Sub End If Mess = "سوف تستغرق عملية فك الحماية ثواني معدودة" & _ vbNewLine & "OK إضغط " & vbNewLine & "وإنتظر حتى يتم فك الحماية " & vbNewLine & _ Credit MsgBox Mess, vbInformation, Header If Not WinTag Then Mess = "" & _ "" & vbNewLine & _ "جاري حذف الحماية " & _ Credit MsgBox Mess, vbInformation, Header Else On Error Resume Next Do For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 With ActiveWorkbook .Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If .ProtectStructure = False And _ .ProtectWindows = False Then PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Mess = "You had a Worksheet Structure or " & vbNewLine & _ Credit MsgBox Mess, vbInformation, Header Exit Do End If End With Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next Loop Until True On Error GoTo 0 End If If WinTag And Not ShTag Then Mess = "Only structure / windows protected with " & vbNewLine & _ "the password that was just found." & vbNewLine & _ AllClear & Credit & RepBack MsgBox Mess, vbInformation, Header Exit Sub End If On Error Resume Next For Each w1 In Worksheets w1.Unprotect PWord1 Next w1 On Error GoTo 0 ShTag = False For Each w1 In Worksheets ShTag = ShTag Or w1.ProtectContents Next w1 If Not ShTag Then Mess = AllClear & Credit & RepBack MsgBox Mess, vbInformation, Header Exit Sub End If For Each w1 In Worksheets With w1 If .ProtectContents Then On Error Resume Next Do For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 .Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If Not .ProtectContents Then PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Mess = "تم حذف كلمة السر " & _ Credit MsgBox Mess, vbInformation, Header For Each w2 In Worksheets w2.Unprotect PWord1 Next w2 Exit Do End If Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next Loop Until True On Error GoTo 0 End If End With Next w1 Mess = AllClear & Credit & RepBack MsgBox Mess, vbInformation, Header End Sub ربنا يبارك في كل واحد يفيد اخوانه بالعلم الذي افاض الله به عليه ربنا يحفظ صاحب هذا العمل .. يارب

الله يبارك لك استاذ عبد السلام

الاستاذ الكريم ابو عبد الباري المعادله الموجوده خاصه بغياب الطلبه في المواد الدراسيه المواد المقرره على الصفوف الاولى 1 - 2 - 3 عباره عن اربع مواد اما المواد المقرره على الصفوف العليا 6 مواد في بيانات المدرسه نحدد ان البرنامج خاص بالصف 1 مثلا في الحاله دي يجمع موادها فقط .. ادعو الله ان تكون وصلت الفكره هل يمكن عمل معادله اخري تؤدي نفس الغرض المعادله التي تفضل بها استاذ سليم .. هل يمكن ان تؤدي الغرض ؟

نسيتني واللا ايه استاذ سليم

عند الضغط على alt + الزر الموجود على يمين اللوحه مع الارقام del لم يظهر اي شيء .. كيف وصلت للمراد