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

**ناصر سعيد** · ديسمبر 25, 2016

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

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

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

**ناصر سعيد** · ديسمبر 30, 2016

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

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

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

**ناصر سعيد** · يناير 16, 2017

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

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

الدالة SumProduct.pdf

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

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

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

**ناصر سعيد** · يناير 16, 2017

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

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

**ناصر سعيد** · يناير 16, 2017

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

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

**ناصر سعيد** · يناير 30, 2017

في ٢٩‏/١‏/٢٠١٧ 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

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

**ناصر سعيد** · يناير 31, 2017

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

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

**ناصر سعيد** · فبراير 6, 2017

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

'================================
'هذا الكود للاستاذ المحترم ياسر العربي
'الهدف من الكود هو استخراج حاله الطالب سواء كان ناجحا او عنده دور تان او غايب
'
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

**ناصر سعيد** · فبراير 10, 2017

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

**ناصر سعيد** · فبراير 11, 2017

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

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

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

**ناصر سعيد** · فبراير 24, 2017

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

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

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

**ناصر سعيد** · فبراير 24, 2017

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

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

ارقام الجلوس.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

**ناصر سعيد** · فبراير 24, 2017

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

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

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


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

**ناصر سعيد** · فبراير 28, 2017

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

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

**ناصر سعيد** · مارس 1, 2017

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

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

**ناصر سعيد** · مارس 2, 2017

مرفق به زياده

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

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

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

inas aly · مارس 3, 2017

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

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

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

رابط الملف

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

**ناصر سعيد** · أبريل 20, 2017

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

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

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

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

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

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

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

**قصي** · أبريل 24, 2017

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

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

ياسر خليل أبو البراء · أبريل 24, 2017

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

محمود محمد عبدو · أبريل 24, 2017

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

**حمادة عمر** · أبريل 24, 2017

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

**ناصر سعيد** · أبريل 25, 2017

شهادات رائعه

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

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

او الفصول

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

شهادات الطلاب بمعايير مختلفه .. لساجده العزاوي.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
''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''

**ناصر سعيد** · أبريل 27, 2017

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

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

مع شرح الكود

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



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

**ناصر سعيد** · أبريل 28, 2017

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

'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

تسجيل الدخول

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

الردود الموصى بها

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

محمدي عبد السميع

محمدي عبد السميع

asdhamdey

Posted Images

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

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

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

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information