[موضوع مميز]شرح عمل شيت كنترول ( درة أعمال العلامة عبد الله باقشير)[مثبت]

[ناصر سعيد]

ولااروع .. سهولة في التطبيق .. سرعه في التنفيذ

كود استدعاء للمبدع ياسر العربي

Sub ALL()
''هذا الكود للعبقري ياسر العربي حفظه الله
'' تم هذا الكود بتاريخ 8 / 10/ 2016
''الهدف من الكود هو استدعاء البيانات
''شرح الكود
''متغيرات
    Dim myArray, lr, X, targt, targt1, targt2, targtN

    Dim SERCH As Worksheet, _
    DATA As Worksheet
    '____________________________________________

    'اسم شيت قاعدة البيانات
    Set DATA = Worksheets("رصد الترم الثانى")

    'اسم الشيت الخاص بالبحث
    Set SERCH = Worksheets("كشوف الطلبه")
    '____________________________________________
    'المدى الذي سيتم مسحه في صفحه الهدف
    Range("D10:AB1000").Clear

    'المدى الذي سيتم نسخه لعدد محدد بخليه محدده
    Range("C9:AB9").AutoFill _
     Destination:=Range("C9:AB" & _
 Range("B4").Value + 8), Type:=xlFillDefault

    'اخر صف به بيانات
    lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row + 2


    'مدى صفحة الهدف وهو يبدأ بعد عمود المسلسل
    'والرقم الموجود هو رقم عمود البدايه
    ' 'مسح نطاق البحث القديم
    SERCH.Range("D9:AB" & SERCH.Cells(Rows.Count, 4) _
                .End(xlUp).Row + 1).ClearContents

    'معيارين البحث
          '  targt2 = targt
    targt = "له* دور ثان في"
    targt2 = "ناجح"
    'نطاق قاعدةالبيانات
    ' صفحة المصدرالذي سيتم البحث فيه
    myArray = DATA.Range("A7:FF" & lr)
    '____________________________________________

   
   ReDim Y(1 To UBound(myArray, 1), 1 To _
   UBound(myArray, 2))
   
    For X = LBound(myArray) To _
    UBound(myArray)
        If targt = "" Then Exit Sub
        
        'هنا التعديل للمعيارين
  If myArray(X, 101) Like targt & "*" _
  Or myArray(X, 101) Like targt2 & _
  "*" Then
                rw = rw + 1
                
           'متغير ارقام
    'الاعمده المطلوب الاستدعاء منها
   'العمود التاني بعد المسلسل
          Y(rw, 1) = myArray(X, 2)
          
              'العمود الثالث بعد المسلسل
          Y(rw, 2) = myArray(X, 3)
          
              'العمود الرابع بعد المسلسل
          Y(rw, 3) = myArray(X, 13)
          
              'العمود الخامس بعد المسلسل
          Y(rw, 4) = myArray(X, 22)
          
              'العمود السادس بعد المسلسل وهكذا
          Y(rw, 5) = myArray(X, 31)
          
          Y(rw, 6) = myArray(X, 40)
          Y(rw, 7) = myArray(X, 51)
          Y(rw, 8) = myArray(X, 52)
          Y(rw, 9) = myArray(X, 82)
          Y(rw, 10) = myArray(X, 101)
          Y(rw, 11) = myArray(X, 102)
        '  Y(rw, 12) = myArray(X, 110)
         ' Y(rw, 13) = myArray(X, 111)
        End If
Next X
If rw > 0 Then SERCH.Cells(Rows.Count, 4).End(xlUp)(2, 1).Resize(rw, 13).Value = Y()
End Sub

 

الاستدعاء بطريقه ( خليفه عبد الله باقشير ) الاستاذ ياسر.rar

[ناصر سعيد]

الاصدار الجديد الثامن

الصف الاول الابتدائي

http://up.top4top.net/downloadf-355u43cq1-rar.html

============================

الصف الثاني الابتدائي

http://up.top4top.net/downloadf-3551s9322-rar.html

============================

الصف الثالث

http://up.top4top.net/downloadf-355c6hdr3-rar.html

============================

الصف الرابع

http://up.top4top.net/downloadf-362xnb4c1-rar.html

============================

الصف الخامس

http://up.top4top.net/downloadf-3622lexk1-rar.html

============================

رابط كلمه السر

http://up.top4top.net/downloadf-top4top_223f4fe93b4-rar.html

===============================================

 

رابط اخر هديه للاستاذ عبد الباري خاص ببرنامج الابتدائي

http://up.top4top.net/downloadf-340rzdbp1-rar.html

=======================================

وهذا رابط لبرنامج الاعدادي

http://up.top4top.net/downloadf-340bahmr1-rar.html

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

 

 

=================================================================

روابط اخرى لما سبق من برنامجين للاستاذ المحترم عبد الباري البنا

كنترول شيت إعدادي ..الدورين معا ..اصدار4

كلمة سر الدخول : 1111

كلمة سر محرر الاكواد : 11223344

كلمة سر صفحة الصلاحيات :6666

كلمة سر تصفير الشيت: 6666

رابط التحميل

كنترول شيت اعدادى 2017

و

كنترول شيت ابتدائى..الدورين معا ..اصدار4

كلمة سر الدخول : 1111

كنترول شيت ابتدائى 2017

 

•  

 

 

 

 

[ناصر سعيد]

شرح الدالة SumProduct للأستاذ يحي حسين

و الملف يحتوي شرح الجزء الأول مع الجزء الثاني

الدالة SumProduct.pdf

منقول للفائده

===================================================

=SUMPRODUCT(--(AG7:AG700="غ"))

 

[ناصر سعيد]

============================

=SUMPRODUCT((F6:F6034="غ")*($DX$7:$DX$6035="ذكر"))

 

[ناصر سعيد]

جعل رقة العمل في اكسل بحدود مطاطية

من ابداع احمد عادل

 

 

[ناصر سعيد]

في ٢٩‏/١‏/٢٠١٧ at 02:17, ياسر خليل أبو البراء said:

تصدير الشهادات كلها إلى ملف PDF

رابط الملف من هنا

جزاك الله كل خير استاذ ياسر

================================================

رائعه المحترم ياسر خليل

كود لتحويل درجات الطلاب لمستويات ( تقديرات ) .. تصلح للترم الاول

 

Option Explicit
' هذا الكود من روائع المحترم ياسر خليل
'الهدف من الكود هو تحويل درجات الطلاب الى مستويات ( تقديرات )
'تم عمل هذا الكود بتاريخ 12/1/2017

Function Level(Mark As Variant, OutOf As Long) As String
    If IsNumeric(Mark) Then
        Mark = Mark / OutOf
        Select Case Mark
            Case Is <= 0
                Level = ""
            Case Is < 0.5
                Level = "دون المستوى"
            Case Is < 0.65
                Level = "مقبول"
            Case Is < 0.75
                Level = "جيد"
            Case Is < 0.85
                Level = "جيد جداً"
            Case Is <= 1
                Level = "ممتاز"
            Case Else
                Level = ""
        End Select
    Else
        Select Case Mark
  Case "غ"
  Level = "غ"
  Case "صفر"
  Level = "دون المستوى"
  Case "واحد"
  Level = "دون المستوى"
  Case "اثنان"
  Level = "دون المستوى"
  Case "ثلاثة"
  Level = "دون المستوى"
  Case Else
  Level = ""
        End Select
    End If
End Function

 

=======================================

Level UDF Using Select Case YasserKhalil ExcelLover.rar

جزاه الله عنا كل خير

[ناصر سعيد]

السلام عليكم
جديد ... جديد ... جديد
للأستاذة ساجدة العزاوي

الجزء 47 هو الجزء الثاني لتسريع كود وذلك باستخدام Application.EnableEvents = False لان تاثير معالج الاحداث غير مرغوب فيه ...Application.Calculation = xlCalculationManual يجب ان نحول الكالكوليشن من اوتوماتك الى مانيول لانه في الاوتوماتيك عند تغيير خلية الاكسل يتاكد من المعادلات الموجودة تعتمد او لا تعتمد على هذه الخلية لذلك ستحدث عمليات حسابية لانحتاجها فالكود ياخذ وقت طويل لذلك نغيره الى مانيول

 

[ناصر سعيد]

كود يصلح للمدارس المصريه لاستخراج حاله الطالب

'================================
'هذا الكود للاستاذ المحترم ياسر العربي
'الهدف من الكود هو استخراج حاله الطالب سواء كان ناجحا او عنده دور تان او غايب
'
Sub اظهار_حاله_الطالب()
'YASSER_ELARABY
    Dim ARR
    Dim ARRY
    Dim ARRYS
    '___________________________________________
    Dim R As Long
    Dim X As Long
    Dim XX As Byte
    Dim ALL_LESS As String
    '___________________________________________
    Const STATUS As Byte = 135    'عمود الحالة ناجح او دور ثان
    Const NOTES As Byte = 136  ' عمود الملاحظات عمود المواد او منقول للصف ا لاخر
    Const GENDER As Byte = 5  ' عمود الجنس ذكر او انثى
    '_____________________________________________________
    Const LESS_ROW As Byte = 6  'صف الدرجة الصغرى
    Const NAM_ROW As Byte = 2    'صف اسماء المواد
    Const NAME_FIRST As Byte = 6 ' اول صف لاسماء الطلاب
    Dim NAME_LAST As Long: NAME_LAST = Sheets("بيانات المدرسة").Range("B10").Value + NAME_FIRST   ' عدد الطلاب
    '_____________________________________________________
    ARR = Array(20, 31, 42, 53, 68, 140)  ' اعمدة اختبار الفصل الدارسي الثاني  لجميع المواد
    ARRY = Array(24, 35, 46, 57, 72, 140)  'اعمدة الدرجة النهائية لجميع المواد
    ARRYS = Array(15, 26, 37, 48, 59, 140)  'اعمدة اسماء كل المواد
    '_____________________________________________________
    With Sheet8    'اسم شيت البيانات
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
        For R = NAME_FIRST To NAME_LAST    ' حلقة تكرارية تبدأ  بأول اسم طالب الى اخر اسم
            For X = 0 To UBound(ARR)    ' حلقة تكرارية تبدأ من الصفر الى اقصى مصفوفة اعمدة اختبار الفصل الدارسي الثاني
                On Error Resume Next
                '____________________________________________________
                'يتم حساب عدد ا لمواد المتغيب بها الطالب او درجتها صفر ويتم وضع عدد المواد في المتغير اكس اكس
                'اذا وصل عدد المواد الى 11 اصبح الطالب متغيب
                If .Cells(R, ARRY(X)) = 0 Or .Cells(R, ARRY(X)) = "غ" Then
                    XX = XX + 1
                End If
                '___________________________________________________
       If ARR(X) = 140 Then 'مجموع
     'لايوجد اختلاف بين هذا الكود وبين الكود الموجود بالاسفل
 If .Cells(R, ARR(X)) < .Cells(LESS_ROW, ARR(X)) Then
   ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " لنصف الدرجة " & " - ": GoTo 86
                        GoTo 86
                    Else
                        GoTo 86
                    End If
                End If
                '____________________________________________________
                'هذا الجزء خاص بمادة العلوم تحديدا الفصل الدراسي الثاني لانه مقسم على عمودين فتم اضافة هذا الجزء ليتم معالجة هذه المرحلة
                If .Cells(R, ARR(X)) < .Cells(LESS_ROW, ARR(X)) Or .Cells(R, ARR(X)) = "غ" Then
                    ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " لثلث الدرجة " & " - ": GoTo 86
                End If
                If .Cells(R, ARRY(X)) < .Cells(LESS_ROW, ARRY(X)) Or .Cells(R, ARRY(X)) = "غ" Then
                    ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " - "
                End If
                '______________________________________________________
86          Next X    'الذهاب الى المادة الاخرى لاعادة تطبيق الكود مرة اخرى حتى انتهاء جميع المواد

            'اذا كان المتغير اكس اكس بيساوي عدد المواد اذن الطالب متغيب
            If XX = 6 Then ALL_LESS = "غياب  ": XX = 0
            '_____________________________________________________
            'هنا بعد اكتمال الكود يتم عمل شرط للمتغير
            'ALL_LESS
            'اذا كان المتغير فارغ اي لم يتم اضافة اي مواد به اذا الطالب ناجح
            If ALL_LESS = "" Then
                If .Cells(R, GENDER) = "ذكر" Then .Cells(R, STATUS) = "ناجح"    'اذا كان نوع الطالب ذكر يتم وضع ناجح
                If .Cells(R, GENDER) = "أنثى" Then .Cells(R, STATUS) = "ناجحه"    'اذا كانت انثى يتم وضع ناجحه
                If .Cells(R, GENDER) = "ذكر" Then .Cells(R, NOTES) = "ومنقول " & Sheets("بيانات المدرسة").Range("B11")     'ويتم وضع في الملاحظات منقول الى ويتم جلب الصف من صفحة الانفو
                If .Cells(R, GENDER) = "أنثى" Then .Cells(R, NOTES) = "ومنقولة " & Sheets("بيانات المدرسة").Range("B11")     'مثل ماسبق
                'اما اذا كان المتغير يحمل اي بيانات لمواد يصبح الطالب له دور ثان
            ElseIf ALL_LESS <> "" Then
                If .Cells(R, GENDER) = "ذكر" Then .Cells(R, STATUS) = "له دور ثان في"    'مثل ما سبق بخصوص النوع
                If .Cells(R, GENDER) = "أنثى" Then .Cells(R, STATUS) = "لها دور ثان في"    '
                .Cells(R, NOTES) = Left(ALL_LESS, Len(ALL_LESS) - 2)    'هنا يتم وضع قيمة المتغير اي المواد في خلية الملاحظات
                ALL_LESS = Empty    'تفريغ المتغير لاعادة تعبئة اسم طالب اخر
            End If
            '_____________________________________________________
        Next R    'الذهاب الى الصف التالي حتى انتهاء عدد الطلاب
    End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
        MsgBox "بتوفيق الله .. تم اظهار النتيجة بنجاح"

End Sub

 

[ناصر سعيد]

شرح توزيع الطلاب على الصفوف

[ناصر سعيد]

=====================

رابط تحميل  الشرح السابق

http://up.top4top.net/downloadf-406iv0gu1-rar.html

[ناصر سعيد]

كود لاظهار اعمدة مختلفة او متجاورة

للمحترم سليم حاصبيا

Sub hide_some_columns()

With Sheets("sheet1")
    .Columns.Hidden = True
    .Range("a1,b1,c1,g1").EntireColumn.Hidden = False
     Application.Goto Reference:=.Range("b1")
End With
Sheets("sheet1").Activate
End Sub

كود لاظهار اعمدة مختلفة او متجاورة

للمحترم ياسر العربي

Sub yasser3()
Columns("D:XFD").EntireColumn.Hidden = True
Range("K:L,O:P,S:T,Z:Z").EntireColumn.Hidden = False
End Sub

 

[ناصر سعيد]

==============================

طباعة ارقام الجلوس للمحترم ياسر العربي

 

ارقام الجلوس.rar

Private Sub CommandButton1_Click()
'هذا الكود للمحترم ياسر العربي
'وهو خاص باستخراج ارقام الجلوس لطلاب المدارس
'تم هذا الكود في 22/2/2017
    Dim x As Long, y As Long, z As Byte
    y = TextBox2.Value
    z = TextBox3.Value
    For x = TextBox1.Value To y
        [B6] = x: If [B6] > TextBox2.Value Then [B6] = ""
        [B16] = x + 3: If [B16] > y Then [B16] = ""
        [B26] = x + 6: If [B26] > y Then [B26] = ""
        [H6] = x + 1: If [H6] > y Then [H6] = ""
        [H16] = x + 4: If [H16] > y Then [H16] = ""
        [H26] = x + 7: If [H26] > y Then [H26] = ""
        [N6] = x + 2: If [N6] > y Then [N6] = ""
        [N16] = x + 5: If [N16] > y Then [N16] = ""
        [N26] = x + 8: If [N26] > y Then [N26] = ""
        ActiveWindow.SelectedSheets.PrintOut Copies:=z ', Preview:=True
        x = x + 8
    Next
    MsgBox "Done.....", 64
    Me.Hide
End Sub
Private Sub UserForm_Activate()
    TextBox1.Text = Sheets("بيانات الطلبة").Range("B7").Value
    TextBox2.Text = Sheets("بيانات الطلبة").Range("B" & Sheets("بيانات الطلبة").Cells(Rows.Count, 2).End(xlUp).Row).Value
End Sub

 

[ناصر سعيد]

==============================

طباعة ارقام الجلوس للمحترم ياسر العربي

الكود مع الشرح

Private Sub CommandButton1_Click()
    Dim x As Long, y As Long, z As Byte
    ' وضع قيمة التكست بوكس 2 داخل المتغير Y
    y = TextBox2.Value
    ' وضع قيمة التكست بوكس 3 داخل المتغير Z
    z = TextBox3.Value
    'حلقة تكرارية بداية من التكست بوكس 1 الى المتغير واي  الذي يحمل قيمة التكست2
    For x = TextBox1.Value To y
        'هنا يتم وضع ارقام الجلوس تباعا لكل خلية من التسع خلايا
        'اول خلية تساوى المتغير اكس والذي يحمل ارقام الجلوس التى حددناها من قبل
        'والخلية التالية نضع املتغير اكس بالاضافة الى واحد ليحمل رقم الجلوس التالي
        'وهكذا مع الخلايا الاخرى الخاصة بارقام الجلوس
        'اما الشروط المضافة بجانب الخلايا IF[]>y then []=""
        'فهذه تم وضعها فقط للتأكد من ان قيمة الخلايا لا تزيد عن اخر رقم جلوس وهو ما يحمله المتغير واي
        'فاذا تحقق الشرط وكان رقم الجلوس اكبر من اخر رقم يتم مسحه وهذه الشروط لا نستعملها الا في اخر صفحة يتم طباعتها
        [B6] = x: If [B6] > TextBox2.Value Then [B6] = ""
        [B16] = x + 3: If [B16] > y Then [B16] = ""
        [B26] = x + 6: If [B26] > y Then [B26] = ""
        [H6] = x + 1: If [H6] > y Then [H6] = ""
        [H16] = x + 4: If [H16] > y Then [H16] = ""
        [H26] = x + 7: If [H26] > y Then [H26] = ""
        [N6] = x + 2: If [N6] > y Then [N6] = ""
        [N16] = x + 5: If [N16] > y Then [N16] = ""
        [N26] = x + 8: If [N26] > y Then [N26] = ""
        'سطر الطباعة وعدد النسخ تساوي z
        'والتى تساوي تكست بوكس تلاته التى نضع بها عدد النسخ المطلوبة
        ActiveWindow.SelectedSheets.PrintOut Copies:=z    ', Preview:=True
        'هنا نقوم باضافة ثمانية ارقام الى المتغير اكس ليصبح محموعهم 9 ليتخطى تسع ارقام جلوس كل دورة
        'داخل الحلقة التكرارية حتى نهاية الحلقة
        x = x + 8
        'نكست اي يعود مرة اخرى لاول الحلقة التكرارية لتطبيق الاكواد مرة اخرى
    Next
    MsgBox "Done.....", 64
    Me.Hide
End Sub
Private Sub UserForm_Activate()
'هنا في حدث تنشيط الفورم
'تكست واحد تساوى اول رقم جلوس
    TextBox1.Text = Sheets("بيانات الطلبة").Range("B7").Value
    'تكست2 تساوي اخر رقم جلوس
    TextBox2.Text = Sheets("بيانات الطلبة").Range("B" & Sheets("بيانات الطلبة").Cells(Rows.Count, 2).End(xlUp).Row).Value
End Sub

 

[ناصر سعيد]

معادله احصاء ب3 شروط

=SUMPRODUCT((($K$10:$K$1000="ذكر")*($AE$10:$AE$1000="ناجح")*($BU$10:$BU$1000="الرابع")))

 

[ناصر سعيد]

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

Sub PrintFrom_To_()
MsgBox "للحصول على طباعة كاملة يجب عدم ملامسة الماوس أو لوحة المفاتيح أثناء الطباعة"
Dim I As Integer
For I = Range("O8") To Range("P8") Step 2
If I <= Range("P8") Then
Range("D4") = I
ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate:=True
End If
Next I
Range("e5").Select
End Sub

================================

معادلات استجلاب البيانات

=IF(COUNTIF('بيانات الطلبة'!$R$6:$R$2030;$D$4)<ROWS(B$9:B9);"";INDEX('بيانات الطلبة'!$E$6:$E$2030;100000-SUMPRODUCT(LARGE(('بيانات الطلبة'!$R$6:$R$2030=$D$4)*(100000-ROW('بيانات الطلبة'!$R$6:$R$2030));ROWS(B$9:B9)))-5))

========================

والمعادله الثانيه معادله صفيف  للمحترم بن عليه هي

=IF($B9="";"";INDEX(MyRng;SMALL(IF('بيانات الطلبة'!$R$7:$R$1000=$D$4;ROW($7:$1000)-6);$B9);4))

 

توزيع اللجان.rar

[ناصر سعيد]

مرفق به زياده

مجرد كتابه عدد اللجان المطلوبه في صفحه بيانات الطلبة

يتم توزيعهم اوتوماتيكيا

 

تـــوزيع اللجان بكتابه عدد اللجان.rar

[inas aly]

الجزء49ترحيل الطلاب على اللجان Formats xlPasteColumnWidthsساجدة العزاوي

http://up.top4top.net/downloadf-416dxcbb1-rar.html

===========================================

رابط الملف

http://up.top4top.net/downloadf-416874e71-rar.html

 

[ناصر سعيد]

استدعاء بيانات اعمده معينه

بطريقه المصفوفات

للاستاذ المحترم زيزو العجوز

جزاه الله كل خير وبارك له

Sub TransData1()
'هذا الكود للمحترم زبزو العجوز
'الهدف من الكود ترحيل بيانات بمعلوميه خليه
'تم هذا الكود في 19/4/2017
'========
'
Dim ws As Worksheet, sh As Worksheet

'اعلان عن متغير شيت الهدف
Set ws = Sheets("M_SH")

'اعلان عن متغير شيت المصدر
Set sh = Sheets("SH")

Dim Arr As Variant, Arr1 As Variant, temp As Variant
Dim LR As Long, i As Long, j As Long, p As Long

'سطر لعد الصفوف في شيت المصدر
LR = WorksheetFunction.CountA(sh.Range("D10:D10000"))

'سطر لمسح النطاق
ws.Range("A9:AJ1000").ClearContents
Arr = sh.Range("A10:DD" & LR).Value
Arr1 = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17, 26, 27, 36, 37, 47, _
48, 59, 60, 67, 68, 71, 72, 76, 77, 81, 82, 86, 87, 91, 92, 97, 98, 105)
ReDim temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)

'سطر اذا كانت قيمه الخليه بي 1 مكتوب فيها شيت نصف العام
If ws.Range("B1").Value = "شيت نصف العام ـ الصف الرابع الابتدائى" Then
p = p + 1
For j = 0 To UBound(Arr1)
temp(p, j) = Arr(i, Arr1(j))
ws.Cells(p + 8, 1) = p
Next j
End If
Next i
If p > 0 Then ws.Range("B9").Resize(p, UBound(temp, 2)).Value = temp

End Sub
Sub TransData2()
Dim ws As Worksheet, sh As Worksheet
Set ws = Sheets("M_SH")
Set sh = Sheets("SH")
Dim Arr As Variant, Arr2 As Variant, temp2 As Variant
Dim LR As Long, i As Long, j As Long, p As Long
LR = WorksheetFunction.CountA(sh.Range("D10:D10000"))
ws.Range("A9:AJ1000").ClearContents
Arr = sh.Range("A10:DD" & LR).Value
Arr2 = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 22, 23, 32, 33, 42, 43, 55, 56, 65, 66, _
69, 70, 74, 75, 79, 80, 84, 85, 89, 90, 93, 94, 103, 104, 107)
ReDim temp2(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr2) + 1)
For i = 1 To UBound(Arr)
If ws.Range("B1").Value = "شيت آخر العام ـ الصف الرابع الابتدائى" Then
p = p + 1
For j = 0 To UBound(Arr2)
temp2(p, j) = Arr(i, Arr2(j))
ws.Cells(p + 8, 1) = p
Next j
End If
Next i
If p > 0 Then ws.Range("B9").Resize(p, UBound(temp2, 2)).Value = temp2
End Sub

 

Using Arrays.rar

==========================

جزاكم الله كل خير

[قصي]

جزاكم الله كل خير .. مجهود عظيم استاذ ناصر

كتبه الله لك في كفة حسناتك

[ياسر خليل أبو البراء]

بارك الله فيكم إخواني الكرام وجزيت خيرا الجزاء

[محمود محمد عبدو]

جزاكم الله خيرا ووفقكم الى ما يحب ويرضى

[حمادة عمر]

جزاكم الله خيرا

[ناصر سعيد]

شهادات رائعه

بمعيه الناجحين او الرسبين

او الاولاد او البنات

او الفصول

وغيره للمبدعه ساجده العزاوي العراقيه

 

شهادات الطلاب بمعايير مختلفه .. لساجده العزاوي.rar

'''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''

'   هذا الكود للنابغه ساجده العزاوي
' وهي من أهلنا بالعراق أعز الله العراق وأذل أعداءه
'تم في 27 يونيو 2016
'كمعطيات المحترم ابو أحمد محمدي

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


Sub محددة_ناجحون()
'   هذا الكود للنابغه ساجده العزاوي
' وهي من أهلنا بالعراق أعز الله العراق وأذل أعداءه
'تم في 27 يونيو 2016
'كمعطيات المحترم ابو أحمد محمدي

' متغيرات يجب تعريفها
Const studentData As String = "رصد الترم الثانى"
Const shehada As String = "شهادة"
'================
lr = Sheets(studentData).Range("C7").End(xlDown).Row
' ايجاد اخر صف موجود به بيانات

c = 2
'فائدتها اذا كانت زوجي يضع البيانات في الشهادة العلوية
'واذا فردي يضع البيانات في الشهادة السفلية بالورقة
'====
'هذه الجزئيه خاصه بجميع الطلاب ( ناجحون ودور تان)
'For i = 7 To LR
'====
'هذه الجزئيه خاصه بطباعة شهادات محدده
For i = Sheets(shehada).Cells(7, 18).Value _
To Sheets(shehada).Cells(7, 19).Value
'من الخلية التي تحوي رو الطبع الى الخلية الثانية التي تحوي الى ار 7 و اس 7

            Application.ScreenUpdating = False
'لتسريع الكود وعدم رؤية مايحدث في الشيت وبذلك يتم اخفاء الرجفة

If c Mod 2 = 0 Then
'نقسم السي على 2 اذا الباقي صفر اذن سي رقمها زوجي ...
'اذا كان زوجي نضع البيانات في الشهادة العلوية

 If Sheets(studentData).Cells(i, 157) Like "*" & "ناج*" & "*" Then
'''If Sheets(StudentData).Cells(i, 157) = "ناجح" Or _
Sheets(StudentData).Cells(i, 157) = "ناجحة" Then
'رقم عمود المعيار وكلمه المعيار الذي نبحث عنها
'
Sheets(shehada).Cells(3, 13) = Sheets(studentData).Cells(i, 2)
'متغير نضع رقم الجلوس في الخلية ام 3 وعند وضعه
'ستظهر البيانات في الخلايا التي وضعنا فيها المعادله

Sheets(shehada).Cells(12, 3) = Sheets(studentData).Cells(i, 157)
Sheets(shehada).Cells(12, 6) = Sheets(studentData).Cells(i, 158)
'نضع محتوى الخلايا سواء فيها ناجح ناجحة
'او لها له دور ثاني ومنقول لصف في الخلايا اعلاه
'
'
c = c + 1
'نزيد العداد حتى يصبح فردي
' وفي اللوب الثاني يذهب الى الشهادة التحت لان العليا ملأناها
'
'
End If
GoTo 1
'يذهب الى 1 لاخذ رقم جلوس اخر
Else
'اذا كان رقم السي فردي

 If Sheets(studentData).Cells(i, 157) Like "*" & "ناج*" & "*" Then

'If Sheets(StudentData).Cells(i, 157) = "له دور ثان في" Or _
   Sheets(StudentData).Cells(i, 157) = "لها دور ثان في" Then
'رقم عمود المعيار وكلمه المعيار الذي نبحث عنها

Sheets(shehada).Cells(19, 13) = Sheets(studentData).Cells(i, 2)
Sheets(shehada).Cells(28, 3) = Sheets(studentData).Cells(i, 157)
Sheets(shehada).Cells(28, 6) = Sheets(studentData).Cells(i, 158)
c = c + 1
Sheets(shehada).Range("a1:p31").PrintOut
'وضعنا الطبع هنا في الاف الثانية وليس الاف الاولى للزوجي
'لان تأكدنا تم مليء الشهادتين بالبيانات
'
'
Sheets(shehada).Cells(3, 13) = ""
Sheets(shehada).Cells(19, 13) = ""
'بعد الطبع يجب تفريغ الخليتين ام3 و ام 19
'  التي تحوي ارقام الجلوس
'
'
End If
End If
1:
Next i
If Sheets(shehada).Cells(19, 13) = "" And Sheets(shehada).Cells(3, 13) <> "" Then
Sheets(shehada).Range("a1:p15").PrintOut
End If
'هذه الاف وضعناها في حالة شهادة فردية
' ففي حالة ام 19 فارغة  معناها شهادة فردية فقط
'الشهادة العلوية فيها بينات ونعطيه امر بطبعها

Application.ScreenUpdating = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''

 

 

 

[ناصر سعيد]

بسم الله الرحمن الرحيم

استخراج القيم الفريده بطريقة العلامه عبد الله باقشير .. حفظه الله ورعاه

مع شرح الكود

جزى الله كل من ساهم في اخراج هذا العمل الى النور بكل خير

Private Sub Worksheet_Activate()
'هذاالكود خاص بالعلامه عبد الله باقشير
'حفظه الله
' الهدف من الكود هو الاتيان بالقيم الفريده
'تم هذا الكود في  23/06/2007
'' '' '' '' '' '' '' '''' '' '' '' '' '' '' ''
Application.ScreenUpdating = False

'مسح عمود القيم الفريده
[V5:V500].ClearContents

'متغير عمود القيم الفريده
Set MyRange = [V5:V500]

'اسم شيت المصدرورقم صف البدايه في شيت المصدر
For U = 7 To Sheets("رصد الترم الثانى").[C1500].End(xlUp).Row

'رقم عمودالبيانات الفريده ورقم عمود بيانات المصدر
   Cells(U, 22) = Sheets("رصد الترم الثانى").Cells(U, 4)
   
   'رقم عمودالبيانات الفريدهفي الشيت الهدف
If Application.WorksheetFunction.CountIf(MyRange, Cells(U, 22)) > 1 Then

'رقم عمودالبيانات الفريده
   Cells(U, 22).ClearContents
End If
Next

'فرز عمود القيم الفريده
[V5:V500].Sort [V5], xlAscending

   Application.ScreenUpdating = True
End Sub

 

استخراج القيم الفريده.rar

[ناصر سعيد]

القيم الفريده بطريقتين  للمحترم عبد الله باقشير والمحترم ياسر خليل

'Private Sub Worksheet_Activate()
Sub القــيم_الفريده()
'Private Sub Worksheet_Activate()

'هذاالكود خاص بالعلامه عبد الله باقشير
'حفظه الله
' الهدف من الكود هو الاتيان بالقيم الفريده
'تم هذا الكود في  23/06/2007
'' '' '' '' '' '' '' '''' '' '' '' '' '' '' ''
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

'مسح عمود القيم الفريده
[S9:S500].ClearContents

'متغير عمود القيم الفريده
Set MyRange = [S9:S500]

'اسم شيت المصدرورقم صف البدايه في شيت الهدف
For U = 9 To Sheets("بيانات الطلبة").[C1500].End(xlUp).Row

'رقم عمودالبيانات الفريده ورقم عمود بيانات المصدر
   Cells(U, 19) = Sheets("بيانات الطلبة").Cells(U, 22)
   
   'رقم عمودالبيانات الفريده في الشيت الهدف
If Application.WorksheetFunction.CountIf(MyRange, Cells(U, 19)) > 1 Then

'رقم عمودالبيانات الفريده
  Cells(U, 19).ClearContents
End If
Next

'فرز عمود القيم الفريده
[S9:S500].Sort [S9], xlAscending

   Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

Sub Unique_List()
'هذاالكود خاص بالمحترم ياسر خليل
'حفظه الله
' الهدف من الكود هو الاتيان بالقيم الفريده
'تم هذا الكود في  28/04/2017

    'تعريف المتغيرات
    Dim Rng As Range
    Dim Cel As Range
    Dim Coll As New Collection
    Dim I As Integer

    'تعيين النطاق المراد استخراج القيم الفريدة منه
    Set Rng = Sheets("بيانات الطلبة").Range("V7:V" & Sheets("بيانات الطلبة").Cells(Rows.Count, 1).End(xlUp).Row)
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    'سطر لتجنب حدوث خطأ لأنه عند إضافة عنصر موجود من قبل يحدث خطأ
    On Error Resume Next

    'حلقة تكرارية لكل خلية من خلايا النطاق
    For Each Cel In Rng
        'إضافة العنصر أو قيمة الخلية ويمثل الجزء بعد الفاصلة مفتاح فريد
        'لتحويل قيمة الخلية لقيمة نصية في حالة التعامل مع الأرقام [Cstr] وتم استخدام الدالة
        Coll.Add Cel.Value, CStr(Cel.Value)
    Next Cel

    'وضع قيم الكائن الذي استخدم في تخزين القيم الفريدة في العمود الثالث
    For I = 1 To Coll.Count
        Sheets("اوائل ").Cells(I + 8, 19).Value = Coll(I)
    Next I
       Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

 

القيم الفريــده.rar