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

[قصي]

شرح معادله INDIRECT

وكذا شرح داله offest

للمبدع ياسر خليل

ملفات مرفقة

•  شرح المعادله    INDIRECT.rar   8.5    كيلو   10 عدد مرات التحميل
•  شرح داله اوفيست للاستاذ ياسر خليل.   rar   11.58   كيلو   9 عدد مرات التحميل

 

•  Index Function.rar   31.48   كيلو   9 عدد مرات التحميل
•  شهادة السحيب الجميلة.rar   20.38كيلو   7 عدد مرات التحميل

[سـامي 169]

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

 

في 18‏/6‏/2015 at 11:18, سـامي 169 said:

 

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

 

[ناصر سعيد]

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

ادراج صفوق بالفورمه.rar

 

•  

 

 

[ناصر سعيد]

Sub معاينه_طباعه()

    Dim SS As Integer
    
    ''من كنوز العلامة عبد الله باقشير
    SS = Range("عدد_الأوراق").Value * 34
    
     Range("A1:L" & SS).RowHeight = 24

    ActiveSheet.PageSetup.PrintArea = "$A$1:$L$" & SS
    ActiveWindow.SelectedSheets.PrintPreview
    [A7].Select
End Sub

كود معاينه مفيد.

[ناصر سعيد]

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

http://up.top4top.net/downloadf-164sjmj1-rar.html

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

http://up.top4top.net/downloadf-1642ojx1-rar.html

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

http://up.top4top.net/downloadf-164sj221-rar.html

 

كلمه السر   1111

[asdhamdey]

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

[asdhamdey]

Sub طباعة_صفحه()
'
'
    ActiveSheet.PageSetup.PrintArea = "$A$1:$N$41"
    ActiveWindow.SelectedSheets.PrintPreview
End Sub

تجميع الاكواد في مكان عاجبني .. ربنا يسعدكم

_استخراج الأوائل.

للمحترم ابو عبد الباري

Sub mh1()


Application.GoTo Reference:="mh"
    Selection.Sort Key1:=Range("q9"), Order1:=xlDescending, Key2:=Range( _
        "t9"), Order2:=xlDescending, Key3:=Range("p9"), Order3:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
        xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, _
        DataOption3:=xlSortNormal
Range("a1").Select
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

 

[asdhamdey]

  ' 'هذا الكود للمحترم ياسر العربي
Sub RoundedRectangle3_Click()
    Dim last As Long
    Dim y As Long
    ''  اول صف سيوضع فيه التذييل
    y = 40
    Do
    
    ' '  لمنع اهتزاز الشاشه
        Application.ScreenUpdating = False
        last = Sheets("ناجح").Cells(Rows.Count, "B").End(xlUp).Row
        If y - 36 >= last Then GoTo 0
        
        ' '  اسم شيت المصدر الذي سيتم حشر الديباجه فيه
        Sheets("كعب الشيت").Rows("2:7").Copy
        
        
        ' '  اسم شيت الديباجه التى نريد وضعها في الشيت المصدر
        Sheets("ناجح").Rows(y).Insert Shift:=xlDown
        
            ' 'لايقاف خاصيه القص والنسخ
        Application.CutCopyMode = False
        
        ' '
        y = y + 36
    Loop
    
    ' ' لاعاده تحديث الشاشه
0   Application.ScreenUpdating = True
    MsgBox "تم بحمد لله"
End Sub
' ' ' ' ' ' ' ' ' ' ' ' ' '

كود لتذييل الصفحه

[عادل زكى]

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

انتظر الرد من حضرتك

 

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

أخي الكريم عادل زكي

بارك الله فيك على كلماتك الطيبة

هلا أرفقت لنا الملف الذي تقصده لأن عدد المشاركات كثيرة في الموضوع ، وحدد الجزئية المطلوب شرحها ليساعدك إخوانك الكرام

كل عام وأنت بخير

[asdhamdey]

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

[asdhamdey]

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

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

كود فلتره في نقس الصعحه

_الطلبة الضعاف.

[asdhamdey]

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

[asdhamdey]

=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);"راسبة";"ناجحة")

 

[ناصر سعيد]

إظهار كل 15 شهادة التالية والسابقة

abo_abary_12.rar

Sub UP()

If Cells(1, 13) <= Cells(1, 14) Then
Cells(1, 13) = Cells(1, 13) + 14
End If
End Sub
Sub DOWN()
If Cells(1, 13) - 14 < 0 Then GoTo 1
If Cells(1, 13) > Cells(1, 15) Then
Cells(1, 13) = Cells(1, 13) - 14
End If

1 End Sub

 

[ناصر سعيد]

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

او شهادات للاولاد فقط او شهادات للبناتفق

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

حاجه روعه وبالشرح

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

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

LR = Sheet1.Range("C7").End(xlDown).Row
' ايجاد اخر صف موجود به بيانات

c = 2
'فائدتها اذا كانت زوجي يضع البيانات في الشهادة العلوية
'واذا فردي يضع البيانات في الشهادة السفلية بالورقة

For i = 7 To LR
'   متغير لوب من صف 7 الي يحوي البيانات الى اخر صف به بيانات

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

If c Mod 2 = 0 Then
'نقسم السي على 2 اذا الباقي صفر اذن سي رقمها زوجي ...
'اذا كان زوجي نضع البيانات في الشهادة العلوية
            If Sheet1.Cells(i, 101) Like "*" & "ناج" & "*" Then
           'If Sheet1.Cells(i, 101) = "ناجــــح" Or Sheet1.Cells(i, 101) = "ناجحــــة" Then
'رقم عمود المعيار وكلمه المعيار الذي نبحث عنها
'
Sheets(2).Cells(3, 13) = Sheets(1).Cells(i, 2)
'متغير نضع رقم الجلوس في الخلية ام 3 وعند وضعه
'ستظهر البيانات في الخلايا التي وضعنا فيها المعادله

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

'            If .Cells(i, 101) Like "*" & "ناجــــح" & "*" Then
If Sheet1.Cells(i, 101) = "ناجــــح" Or Sheets(1).Cells(i, 101) = "ناجحــــة" Then
'''رقم عمود المعيار وكلمة المعيار

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

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

شهادات محدده

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

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


LR = Sheets(1).Range("C7").End(xlDown).Row
' ايجاد اخر صف موجود به بيانات

c = 2
'فائدتها اذا كانت زوجي يضع البيانات في الشهادة العلوية
'واذا فردي يضع البيانات في الشهادة السفلية بالورقة

For i = Sheets(2).Cells(7, 18).Value To Sheets(2).Cells(7, 19).Value
'من الخلية التي تحوي رو الطبع الى الخلية الثانية التي تحوي الى ار 7 و اس 7

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

If c Mod 2 = 0 Then
'نقسم السي على 2 اذا الباقي صفر اذن سي رقمها زوجي ...
'اذا كان زوجي نضع البيانات في الشهادة العلوية
'
If Sheets(1).Cells(i, 128) = "ذكر" Then
'رقم عمود المعيار وكلمه المعيار الذي نبحث عنها
'
Sheets(2).Cells(3, 13) = Sheets(1).Cells(i, 2)
'متغير نضع رقم الجلوس في الخلية ام 3 وعند وضعه
'ستظهر البيانات في الخلايا التي وضعنا فيها المعادله

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


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

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

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

النابغه من اهلنا بالعراق حفظ الله العراق واذل كل من دمره

شهادات من النابغه ساجده 1.rar

[ناصر سعيد]

استخراج دون المستوى الطلاب الضعاف في كل المواد للمحترم ياسر العربي

Sub دون_المستوى()
''''' هذا الكود للاستاذ المحترم ياسر العربي
''' جزاه الله كل خير
'''  هذا الكود خاص باستخراج الطلاب دون المستوى
'''
'''

    Dim LR As Integer, R As Integer, T As Integer, z As Integer

    'حذف النطاق الموجود لجلب بيانات جديدة
    Range("c6:d100").ClearContents

    'يشير حرف التيي الى اول صف هنحط فيه بيانات
    T = 6

    ''''  متغير اسم شيت الهدف _دون المستوى واسم الخليه_
    z = Sheet3.Range("R1").Value

    ''''  متغير اسم شيت الهدف _دون المستوى واسم الخليه_
    y = Sheet3.Range("R2").Value

    '''''
    With Sheet1
        LR = .Cells(.Rows.Count, 1).End(xlUp).Row
        For R = 7 To LR
        
            Application.ScreenUpdating = False

            If .Cells(R, z) Like "*" & "دون المستوى" & "*" Then


                ''''  متغير اسم شيت الهدف _دون المستوى
                Sheet3.Cells(T, 3) = .Cells(R, 3)


                ''''  متغير اسم شيت الهدف _دون المستوى
                Sheet3.Cells(T, 4) = .Cells(R, y)
                T = T + 1
            End If
        Next
    End With
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True

End Sub

 

استخراج دون المستوى للمحترم ياسر العربي.rar

[ناصر سعيد]

23 ساعات مضت, ناصر سعيد said:

إظهار كل 15 شهادة التالية والسابقة

abo_abary_12.rar

إظهار كل 15 شهادة التالية والسابقة
تعديل طفيف من المحترم ياسر خليل
Sub UP()
    If Cells(1, 13) + 14 >= Cells(1, 14) Then Cells(1, 13) = Cells(1, 14): Exit Sub

    If Cells(1, 13) <= Cells(1, 14) Then
        Cells(1, 13) = Cells(1, 13) + 14
    End If
End Sub

Sub DOWN()
    If Cells(1, 13) - 14 <= 0 Then Exit Sub

    Cells(1, 13) = Cells(1, 13) - 14
End Sub

 

تعديل

طفيف من المحترم ياسر خليل

[ناصر سعيد]

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

شاء الله تعالى ان يجتمع عملان لافذاذ المنتدى  وهما العالم العلامه والبحر الفهامه عبد الله باقشير

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

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

اولا : هذا كود العلامه عبد الله باقشير  حفظه الله .. بشرح اسطر الكود

Option Explicit
''هذا الكود للعالم العلامه والبحر الفهامه عبد الله باقشير
''الهدف من الكود
''استخراج حاله الطالب سواء كان ناجح او دور تان او غايب
''وقد تمت اضافة جزئيه حسب المتطلبات الجديده للمدارس
''بفضل الله اولا ثم العبقري ياسر العربي
'         اسماء المواد
Const nTEST As String = "عربي" & "," & _
      "رياضيات" & "," & _
      "دراسات" & "," & _
      "انجليزى" & "," & _
      "علوم" & "," & _
      "مجموع" & "," & _
      "رسم" & "," & _
      "العاب" & "," & _
      "نشاط1" & "," & _
      "نشاط 2" & "," & _
      "دين"
'--------------------------------------
'         ارقام اعمدة الدرجة الاصلية
'          بالتسلسل حسب اسماء الموادوعددها
Const ColmnTotal As String = "13,22,31,40,51,57,54,59,64,69,82"
'         ارقام اعمدة الفصل الثاني
'ويجب ان يتساوى عددها
'مع عدد اسماء المواد 'لعليا التي كتبت
'         وهنا المجموع ً
Const ColmnTest2 As String = "9,18,27,36,47,54,57,62,67,72,78"
'         رقم صف النهاية الصغرى
Const iRs As Integer = 6
'         اول صف للبيانات
Const TopRow As Integer = 7
Sub kh_Tgrba()
    Dim sCont As Integer, R As Integer
    Dim Tst As String
    Dim xx As String
    Dim xxx As String
    Dim go As String
    Dim Arr, i, x
    On Error GoTo 0
    '------------------
    '   عدد  الطلبة
    '    ممكن يؤخذ من خلية او يكتب كتابة
    sCont = Sheets("بيانات المدرسة").Range("B10").Value
    '---------------------------------------
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    '------------------
    sCont = sCont + TopRow
    With ActiveSheet
        For R = TopRow To sCont
            If Not IsEmpty(.Cells(R, "C")) Then
                Tst = kh_Test(R)
                '''الاضافه هنا
                '--متغير اســم ورقم العمود
                '_ما تم التعديل عليه هذه الجزئية تم اضافة عليها بعض الاسطر
                Select Case .Cells(R, 112)
                    'لتحديد النوع للطالب
                Case 1: xx = "له دور ثان في": xxx = "ناجح": go = "ومنقول " & Sheets("بيانات المدرسة").Range("b16")
                Case 2: xx = "لها دور ثان في": xxx = "ناجحه": go = "ومنقوله " & Sheets("بيانات المدرسة").Range("b16")
                End Select
                If Len(Tst) Then .Cells(R, "CW") = xx Else .Cells(R, 101) = xxx
                '--متغير اسم العمود
                'عمود ملاحظات المواد
                .Cells(R, "CX") = kh_Test(R)
                '--متغير رقم العمود
                'عمود رقم النتيجة
                Select Case .Cells(R, 101)
                    '--متغير اسم العمود
                    'اذا كان الطالب ناجح او ناجحةاذن يتم اعتماده منقول او منقوله للصف التالي
                Case xxx: .Cells(R, "CX") = go
                End Select
                x = 0
                ''مصفوفة باسماء خلاياالمواد
                ''متغير أسماء اعمدة اختبار الترم التاني
                Arr = Array(.Range("i" & R), .Range("r" & R), .Range("aa" & R), .Range("aj" & R), .Range("at" & R), .Range("au" & R), .Range("bb" & R), .Range("bg" & R), .Range("bl" & R), .Range("bq" & R), .Range("bz" & R))
                ' حلقة تكرارية للبحث داخل المصفوقة عن الغائب اذا وجد يتم اضافته للمتغير اكس
                For Each i In Arr
                    Select Case i
                    Case "غ": x = x + 1
                    End Select
                Next
                'اذا كان المتغير اكس يساوي عدد  جميع مواد الترم الثاني اذن هو غائب
                Select Case x
                Case 11: .Cells(R, "CX") = "غياب"
                End Select
                'الشرط الثاني اذا كان المجموع يساوي صفر اذن غائب
                Select Case .Cells(R, 52)
                Case 0: .Cells(R, "CX") = "غياب"
                End Select
                'اذا كان الطالب باق بشرط ان كون في الصف الاول او الثاني يصبح ناجح بحكم القانون
                If .Cells(R, 111) = "باق" And (Sheets("بيانات المدرسة").Range("b12") = 1 Or Sheets("بيانات المدرسة").Range("b12") = 2) Then: .Cells(R, "CX") = go & " بحكم القانون": .Cells(R, "Cw") = xxx
                '____________________________________________
            End If

        Next
    End With
1:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    If Err Then
        MsgBox "Err.Number : " & Err.Number
        Err.Clear
    Else: MsgBox "تم اظهار النتيجة بنجاح"
    End If
End Sub
Function kh_Test(iRow As Integer) As String
    Dim vT, sT
    Dim NN As String, TT As String
    Dim ctlt As Integer, ctst As Integer
    Dim c As Integer, CC As Integer
    Dim ib As Boolean
    CC = UBound(Split(nTEST, ","))
    For c = 0 To CC
        ib = False
        NN = Split(nTEST, ",")(c)
        ctlt = Split(ColmnTotal, ",")(c)
        ctst = Split(ColmnTest2, ",")(c)
        vT = Cells(iRow, ctlt)
        If Not IsEmpty(vT) Then
            Select Case vT
            Case Is = "غ", "غـ": ib = True
            Case Is < Cells(iRs, ctlt): ib = True
            End Select
        End If
        If ctst = 0 Then GoTo 1
        sT = Cells(iRow, ctst)
        If Not IsEmpty(sT) Then
            Select Case sT
            Case Is = "غ", "غـ"
                NN = NN & " لثلث الدرجة": ib = True
            Case Is < Cells(iRs, ctst)
                NN = NN & " لثلث الدرجة": ib = True
            End Select
        End If
1:
        If ib Then TT = TT & IIf(Len(TT), " - ", "") & NN
    Next
    kh_Test = TT
End Function

 

 

استخراج حاله الطالب للعلامه عبد الله باقشير.rar

ثانيا: هذا كود العبقري ياسر العربي  حفظه الله .. بشرح اسطر الكود

Sub Yasser()
''هذا الكود للعبقري ياسر العربي حفظه الله
'' تم هذا الكود بتاريخ 10 / 7/ 2016
''استخراج حاله الطالب سواء كان ناجح او دور تان او غايب
''شرح الكود
'' 3 متغيرات
    Dim LR As Integer, _
        LR1 As Integer, _
      T As Integer
    ''صف البدايه
    T = 7
    ''متغير اسم شيت الرصد
    With Sheets(1)
        ''موقع رقم الجلوس
        LR1 = .Cells(7, 2)
        '' متغير اسم شيت الجدول
        ' هنا يتم جلب اول رقم الجلوس الى شيت المعادلات للعمل عليه
        Sheet3.Range("c6") = LR1
        'متغير لمعرفة اخر صف به بيانات
        LR = .Cells(.Rows.Count, 1).End(xlUp).Row
        ''المدى المطلوب مسحه لكتابة حاله الطالب فيه
        Range("cw7:cx" & LR).ClearContents
        'حلقة تكرارية من اول طالب الى اخر طالب
        For R = 7 To LR
            'اذا كانت قيمة حرف التيي اكبر من او يساوي اخر طالب يذهب خارج الحلقة التكرارية الى السطر صفر
            If T - 1 >= LR Then
                GoTo 0
            Else
                'ايقاف تحديث الشاشة
                Application.ScreenUpdating = False
                'هنا يتم تطبيق كود اكس اكس الخاص بوضع الفواصل بين المواد
                xxx
                ''متغر اسم شيت الجدول
                ''وموقع الخلايا التي سيتم لصقها في عمودي الحاله 101  و 102
                .Cells(T, 101) = Sheet3.Cells(2, 9)
                ''متغر اسم شيت الجدول
                ''وموقع الخلايا التي سيتم لصقها في عمودي الحاله 101  و 102
                .Cells(T, 102) = Sheet3.Cells(2, 10)
                'هنا قيمة الخلية المذكورة الخاصة برقم جلوس
                '  الطالب تساوي نفسها +1 للذهاب الى الطالب التالي لتطبيق الكود مره اخرى
                Sheet3.Range("c6").Value = Sheet3.Range("c6").Value + 1
                'وهنا بالمثل نضيف واحد الى هذا المتغير للنزول الى الصف التالي وهكذا حتى تنتهي البيانات
                T = T + 1
            End If
        Next
    End With
    '' متغير اسم شيت الجدول وموقع الخليه
0   Sheet3.Range("c6") = LR1
    'اعادة تحديث الشاشة
    Application.ScreenUpdating = True
    MsgBox "تم بحمد الله"
End Sub
''--------------------------------------------------------
Sub xxx()
''هذا الكود للعبقري ياسر العربي حفظه الله
'' تم هذا الكود بتاريخ 10 / 7/ 2016
'' هذف الكود هو وضع شرطه بين مواد الدور التاني
''شرح الكود
    With Sheet3
        Dim Rng As Range
        'حلقة تكرارية لصف المواد التى لها دور ثان
        For Each Rng In .Range("d10:n10")
            'اذا كانت الخلية بها بيانات اذن يتم تطبيق التالي
            If Rng <> "" Then
                'ضع المادة بالخلية الموضحه
                .Range("j11") = .Range("j11") & Rng
                'وضع الشرطة بعد كل مادة
                .Range("j11") = .Range("j11") & " -"
            End If
        Next Rng
        'بعد الانتهاء من وضع كل الفواصل تظل شرطة اخيرة يتم حذفها بهذه  الطريقة
        .Range("J12").FormulaR1C1 = "=LEFT(R[-1]C,LEN(R[-1]C)-1)"
        .Range("J12") = .Range("J12").Value
        .Range("j11").ClearContents
    End With
End Sub

 

استخراج حاله الطالب للعبقري ياسر العربي.rar

حفظ الله كل من ساهم في اخراج هذا العمل المتميز

[ناصر سعيد]

LastRow_1 = Cells(Rows.Count, "C").End(xlUp).Row + 12
Range("AY13:AZ" & LastRow_1).ClearContents

Dim MyBoolean As Boolean
Sub اضافة_حذف()
On Error Resume Next
Dim XX As Shape
Set XX = ActiveSheet.Shapes("الدائرة")
With XX.TextFrame.Characters
    If .Text = "اضافة الدوائر" Then
       Circles1
       .Text = "حذف الدوائر"
    Else
       Kh_DeletShape
       .Text = "اضافة الدوائر"
    End If
End With
On Error GoTo 0
End Sub
Sub Circles1()
On Error Resume Next
Dim MyRng_All As Range, c As Range
Dim V As Shape, S As String
Dim K As Integer, x As Integer, d As Long, N As Integer, y As Integer
Dim عمود_رقم_الجلوس As Integer, صف_مواد_دور_ثاني As Integer, صف_الدرجات As Integer
Dim عمود_حالة_الطالب As Integer, عمود_المواد As Integer
'================================================
عمود_رقم_الجلوس = 2
صف_الدرجات = 12
صف_مواد_دور_ثاني = 8
عمود_حالة_الطالب = 51
عمود_المواد = 52
   y = Sheets("بيانات المدرسة").Range("B10").Value + 12
   Set MyRng_All = Range("p13", Cells(y, 51)) ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
x = ActiveWindow.Zoom
Application.ScreenUpdating = False


LastRow_1 = Cells(Rows.Count, "C").End(xlUp).Row + 12
Range("AY13:AZ" & LastRow_1).ClearContents

ActiveWindow.Zoom = 100
For Each c In MyRng_All
    K = c.Column
    If Cells(c.Row, عمود_رقم_الجلوس) = 0 Then GoTo 3
    If Cells(صف_مواد_دور_ثاني, c.Column) <> "م" Then
        If IsNumeric(Cells(صف_الدرجات, c.Column)) And Not IsEmpty(Cells(صف_الدرجات, c.Column)) _
            And (c.Value < Cells(صف_الدرجات, c.Column) Or c.Value = "غ" Or c.Value = "غـ") Then
            If MyBoolean Then GoTo 1
            Kh_AddShape c, V
            d = d + 1
        End If
1
    Else
        If IsNumeric(Cells(صف_الدرجات, c.Column)) And Not IsEmpty(Cells(صف_الدرجات, c.Column)) _
            And (c.Value < Cells(صف_الدرجات, c.Column) Or Cells(c.Row, c.Column - 1) < Cells(صف_الدرجات, c.Column - 1) Or Cells(c.Row, c.Column - 1) = "غ" Or Cells(c.Row, c.Column - 1) = "غـ") Then
            If Cells(c.Row, c.Column - 1) = "غ" Or Cells(c.Row, c.Column - 1) = "غـ" Then N = N + 1
            '================================================
'           ترحيل مواد دورثاني ان وجدت
            If Cells(c.Row, عمود_المواد) = "" Then S = "" Else S = " - "
            Cells(c.Row, عمود_المواد) = Cells(c.Row, عمود_المواد) & S & Cells(صف_مواد_دور_ثاني - 1, c.Column)
            '================================================
            If MyBoolean Then GoTo 2
            Kh_AddShape c, V
            d = d + 1
        End If
    End If
   '================================================
'           ترحيل حالة الطالب
2
    If K = MyRng_All.Columns.Count + MyRng_All.Column - 1 Then
        If N = 4 Then Cells(c.Row, عمود_حالة_الطالب) = "غائب": Cells(c.Row, عمود_المواد) = "جميع المواد" _
        Else If Cells(c.Row, عمود_المواد) = "" Then Cells(c.Row, عمود_حالة_الطالب) = "ناجح ومنقول للصف الثالث" Else Cells(c.Row, عمود_حالة_الطالب) = "له دور ثاني في"
        N = 0
    End If
   '================================================
3 Next
ActiveWindow.Zoom = x
Application.ScreenUpdating = True
If MyBoolean Then GoTo 4
MsgBox "تم إضافة   " & d & "   دائرة بنجاح" & Chr(10) & Chr(10) & "تم تحديث حالةالطالب" & Chr(10) & Chr(10) & "تم تحديث مواد دور ثاني", vbMsgBoxRight, "الحمدلله"
On Error GoTo 0
4 End Sub
Sub Kh_AddShape(MyCell As Range, Kh_shp As Shape)
    Set Kh_shp = ActiveSheet.Shapes.AddShape(msoShapeOval, MyCell.Left, MyCell.Top, MyCell.Width, MyCell.Height)
    With Kh_shp
        .Fill.Visible = msoFalse
        .Line.ForeColor.SchemeColor = 10
        .Line.Weight = 2.25
    End With
End Sub
Sub Kh_DeletShape()
    Dim myshape As Shape, d As Long
    For Each myshape In ActiveSheet.Shapes
      If myshape.Type = 1 Then myshape.Delete: d = d + 1
    Next myshape
MsgBox "تم حذف   " & d & "   دائرة بنجاح", vbMsgBoxRight, "الحمدلله"
End Sub
Sub تحديث()
MyBoolean = True
Circles1
MyBoolean = False
MsgBox "تم تحديث حالةالطالب" & Chr(10) & Chr(10) & "تم تحديث مواد دور ثاني", vbMsgBoxRight, "الحمدلله"
End Sub

ماسبق كود آخر لاستخراج حاله الطالب بطريقه اخرى لللامه عبد الله باقشير

http://www.officena.net/ib/applications/core/interface/file/attachment.php?id=113355

[ناصر سعيد]

استدعاء بيانات بطريقتين

Sub KH_START()
''هذا الكود للعالم العلامه والبحر الفهامه عبد الله باقشير حفظه الله
'' تم هذا الكود بتاريخ 10 / 7/ 2008
'' استدعاء الناجحين والدور التاني     الهدف من الكود
''شرح الكود
''  متغيرات

Dim b As Integer, M As Integer
 
    Sheets("كشف ناجح").Range("c7:m1000").ClearContents
        
        Sheets("كشف الدور الثاني").Range("c7:m1000").ClearContents
                    M = 7: b = 7
    For R = 1 To 1000
    
          Application.ScreenUpdating = False
       Application.Calculation = xlCalculationManual

         ' If .Cells(R, z) Like "*" & "دون المستوى" & "*" Then

            If Sheets("رصد الترم الثانى").Cells(R, 101) Like "*" & "ناج" & "*" Then
            Sheets("رصد الترم الثانى").Range("A" & R).Range("b1:c1,m1,v1,ae1,an1,ay1,az1,cd1,cx1,cw1").Copy
            Sheets("كشف ناجح").Range("c" & M).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            M = M + 1
            End If
            
                        If Sheets("رصد الترم الثانى").Cells(R, 101) _
                        Like "*" & "دور ثان فى" & "*" Then
          '  If InStr(1, Sheets("رصد الترم الثانى").Cells(R, 101).Value, "دور ثان فى") Then
                Sheets("رصد الترم الثانى").Range("A" & R).Range("b1:c1,m1,v1,ae1,an1,ay1,az1,cd1,cx1,cw1").Copy
                Sheets("كشف الدور الثاني").Range("c" & b).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            b = b + 1
            End If
    Next
  
    MsgBox ("الحمد لله تـــم ترحيل الناجحين و الراسبين إلى أوراق عمل جديدة ")
    
    Range("a1").Select

         Application.Calculation = xlCalculationAutomatic

    Application.ScreenUpdating = True
End Sub

'------------------------------------------------
'------------------------------------------------

Sub Naageh_Raseb()
'يقوم الكود بترحيل الناجحين والراسبين في أوراق العمل المخصصة لذلك
'----------------------------------------------------------------
'تعريف المتغيرات
    Dim RowNageh As Long, RowRaseb As Long
    
    
    Dim WS As Worksheet, SHNageh As Worksheet, SHRaseb As Worksheet
    
    
'تعيين متغيرات أوراق العمل
    Set WS = Sheets("رصد الترم الثانى"): Set SHNageh = Sheets("كشف ناجح"): Set SHRaseb = Sheets("كشف الدور الثاني")
    
    
'مسح محتويات النطاق الذي سيتم الترحيل إليه في ورقة الناجحين
    SHNageh.Range("C7:M1000").ClearContents
    
    
'مسح محتويات النطاق الذي سيتم الترحيل إليه في ورقة الراسبين
    SHRaseb.Range("C7:M1000").ClearContents
    
    
'صف البداية الذي سيتم الترحيل إليه في ورقة الناجحين وورقة الراسبين
    RowNageh = 7 _
         : RowRaseb = 7
    
'إلغاء خاصية اهتزاز الشاشة
    Application.ScreenUpdating = False
    
'حلقة تكرارية في ورقة البيانات الأساسية بداية من الصف رقم 11 حتى آخر صف
        For R = 7 To WS.Cells(Rows.count, 1).End(xlUp).Row
        
        
'يمثل الرقم 101 رقم العمود الذي به النتيجة في ورقة البيانات الأساسية
'إذا كانت الخلية في الصف المحدد في عمود النتيجة تساوي كلمة ناجح
            If InStr(1, WS.Cells(R, 101), "ناجح") Then
            
            
'نسخ النطاقات المحددة في الصف المحدد في حالة تحقق الشرط
 WS.Range("A" & R).Range("B1:C1,Z1,m1,v1,AE1,AN1,ay1,AZ1,cd1,cx1").Copy
                
                
'لصق البيانات المنسوخة إلى العمود الثالث في ورقة الناجحين
                SHNageh.Range("C" & RowNageh).PasteSpecial xlPasteValues
                
                
'إلغاء خاصية القص والنسخ
                Application.CutCopyMode = False
                
'زيادة المتغير بمقدار واحد استعداداً لبيانات جديدة
                RowNageh = RowNageh + 1
                
'إذا كانت الخلية في الصف المحدد في عمود النتيجة تساوي كلمة دور ثان في
            ElseIf InStr(1, WS.Cells(R, 101), "دور ثان فى") Then
            
'نسخ النطاقات المحددة في الصف المحدد في حالة تحقق الشرط
                WS.Range("A" & R).Range("B1:C1,Z1,AI1,AR1,BA1,BL1,BM1,CD1,DI1,DJ1").Copy
                
'لصق البيانات المنسوخة إلى العمود الثالث في ورقة الراسبين
                SHRaseb.Range("C" & RowRaseb).PasteSpecial xlPasteValues
                
'إلغاء خاصية القص والنسخ
                Application.CutCopyMode = False
                
'زيادة المتغير بمقدار واحد استعداداً لبيانات جديدة
                RowRaseb = RowRaseb + 1
                
            End If
            
            
'الانتقال للصف التالي في ورقة البيانات الأساسية
        Next
        
'رسالة تفيد بانتهاء عملية الترحيل
        MsgBox ("الحمد لله تم ترحيل الناجحين و الراسبين إلى أوراق عمل جديدة"), vbInformation
        
'إعادة تفعيل خاصية اهتزاز الشاشة
    Application.ScreenUpdating = True
End Sub

 

استدعاء الناجحين والدور التاني1.rar

 

 

تم تعديل يوليو 30, 2016 بواسطه ناصر سعيد
تكبير الخط

[ناصر سعيد]

 

37 دقائق مضت, ناصر سعيد said:

If Sheets("رصد الترم الثانى").Cells(R, 101) Like "*" & "ناج" & "*" Then

سطر رااائع

[بوب2016]

في ٢١‏/٤‏/٢٠١٢ at 09:11, عبدالله المجرب said:

اخي محمدي

تم افتتاح مكتبة الاكواد وهذا رابطه

http://www.officena.net/ib/index.php?app=downloads&showcat=16

لما لا تستغله في هذه السلسلة التعليمية حتي يسهل الرجوع اليه

والامر متروك لك

أ / عبد الله ..سؤال ... عندما ارفق ملف يقرأه كأنه صورة  ويرفض التحميل ...لماذا ؟

[ناصر سعيد]

استخراج شهادات الطلاب كل شهاده في ورقه واحده للنابغه ساجده العزاوي

 

شهاده في ورقه واحده للنابغه ساجده.rar

[ناصر سعيد]

كود للطباعه راائع محدد بعدد الصفحات التي تبغاها

جزى الله صاحبه بكل خير

Sub Print_shehada()
' ==== هذا الكود للمحترم مختار حسين محمود
Dim i As Integer
   
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   
   For i = Range("t4") To Range("w4")
   Range("t4") = i
     
   If i <= Range("w2") Then
   ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

   End If
 
   Next i

   
   Range("t4").Select
   Range("t4") = 1
   Range("w4") = ""
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   
   MsgBox "بحمد الله تعالى طباعة الشهادات", vbInformation + vbMsgBoxLEFT, " مع تحيات / مختار حسين محمود "
End Sub

 

 

طباعة مرن مع البحث بدلالة رقم الجلوس.rar