استخراج الشهادات وأوائل الطلبه بطريقه متميزة

[ناصر سعيد]

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

All Certificates print_ FORM OR ALL OR PDF _By _MZMELSHRIEF+PR_N_R_H_L.rar

 

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

تنسيق الاستاذ محمود الشريف

[ناصر سعيد]

شهادات بطريقة المبدعه ساجده

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

 

 

شهادات رائعه لساجدة.rar

[ناصر سعيد]

نسخه ولا اروع الجديد فيها

في الشهادات انها تستيطيع ان تستخرج

الناجح والناجحه او الراسب والراسبه

       If .Cells(R, 1) Like "*" & Nd & "*" Then

 

 

أوائــــــل الطلبه والشهادات وشهادة التقدير.rar

==========

هذا السطر البرمجي خاص بالمحترم الاستاذ ياسر خليل

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

[ناصر سعيد]

شهادات رائعه بمعايير مختلفه - شهادات الناجحين - شهادات الراسبين - شهادات الولاد - شهادات البنات - شهادات محدده

للمحترمه ساجده العزاوي العراقيه

 

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

[قصي]

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

[ناصر سعيد]

شهادات بطريقه العلامه عبد الله بتنسيقات جديده

'***********************************************
'***********************************************
'     اسم ورقة الشهادات
Const ShName As String = "شهادات الصف الثانى"
'     رقم اول صف للشهادة
Const FirstRow As Integer = 7
'     عدد صفوف الشهادة
Const CountRow As Integer = 16
'عدد اعمدة الشهادة التي تريد اظهارها في الطباعة
Const CountColumn As Integer = 13
' خلية موقع الطالب  لمعادلات الشهادة
Const Range_Index As String = "A7"

'=====================================
'     اسم ورقة البيانات
Const Sh As String = "بيانات أساسية"
' نطاق ناجح دور ثاني في ورقة البيانات
Const MyND As String = "Q6:Q5000"
' نطاق الاسماء في ورقة البيانات
Const MyNSearch As String = "C6:C5000"

'=====================================
'   خلية عدد كل المتقدمين
Const CountAll As String = "Q1"
'    خلية عدد الناجحين
Const CountNA As String = "Q2"
'   كلمة البحث عن الناجحين
Const NA_G As String = "نا*"
'   خلية عدد دور ثاني
Const CountDT As String = "Q3"
'   كلمة البحث عن دور ثاني
Const DT_G As String = "له* دور تان"

'Const CountDOR As String = "Q4"
'   كلمة البحث عن دور ثاني
'Const DT_G As String = "له* دور تان"

'*************************
'==========================
'   خلية عدد كل المتقدمين

Dim kh_Test As Boolean
Sub All_Students_2()
Application.ScreenUpdating = False
kh_ClearContents_2
With Sheets(ShName)
    .Range(Range_Index).Value = 1
    Call kh_Test_Fill(.Range(CountAll))
    End With
    If kh_Test Then
Application.ScreenUpdating = True
End If
AddPageBreaks
Range("b1").Select
End Sub
Sub Successful_Students_2()
Application.ScreenUpdating = False
kh_ClearContents_2
With Sheets(ShName)
    Call kh_Test_Fill(.Range(CountNA))
    If kh_Test Then Call kh_Nd(NA_G)
End With
Application.ScreenUpdating = True
AddPageBreaks
Range("b1").Select
End Sub
Sub Second_Students_2()
Application.ScreenUpdating = False
kh_ClearContents_2
With Sheets(ShName)
    Call kh_Test_Fill(.Range(CountDT))
    If kh_Test Then Call kh_Nd(DT_G)
End With
Application.ScreenUpdating = True
AddPageBreaks
Range("b1").Select
End Sub
Sub DOR_Students_2()
Application.ScreenUpdating = False
kh_ClearContents_2
With Sheets(ShName)
    Call kh_Test_Fill(.Range(CountDOR))
    If kh_Test Then Call kh_Nd(DOR_G)
End With
Application.ScreenUpdating = True
AddPageBreaks
Range("b1").Select
End Sub
Sub Item_Search_2()
Dim NN As Integer, R As Integer, c As Integer, rr As Long
NN = form_Search_2.CM_ListAdd.ListCount
Application.ScreenUpdating = False
kh_ClearContents_2
With Sheets(ShName)
    If NN = 1 Then
        .Range(Range_Index).Value = form_Search_2.CM_ListAdd.List(0, 1)
    Else
        Call kh_AutoFill(NN)
        rr = .Range(Range_Index).Row
        c = .Range(Range_Index).Column
        For R = 0 To NN - 1
            .Cells(rr, c) = form_Search_2.CM_ListAdd.List(R, 1)
            rr = rr + CountRow
        Next
    End If
    ActiveWorkbook.Application.DisplayFullScreen = False
End With
Unload form_Search_2
Application.ScreenUpdating = True
End Sub
Sub kh_Test_Fill(MyCel As Range)
If IsNumeric(MyCel) And MyCel.Value > 0 Then
    kh_Test = True
    If MyCel.Value <> 1 Then Call kh_AutoFill(MyCel.Value)
Else
    kh_Test = False
    MsgBox MyCel.Offset(0, -1) & Chr(10) & Chr(10) & Val(MyCel), 524288 + 1048576 + 16, "بيانات غير متوفرة"
End If
End Sub
Sub kh_AutoFill(R As Integer)
Dim SourceRange As Range, fillRange As Range
Dim rr As Long
rr = (R * CountRow)
With Sheets(ShName)
    Set SourceRange = .Rows(FirstRow).Resize(CountRow)
    Set fillRange = .Rows(FirstRow).Resize(rr)
    SourceRange.AutoFill fillRange, xlLinearTrend
    .PageSetup.PrintArea = .Range("B" & FirstRow).Resize(rr, CountColumn).Address
End With
End Sub
Sub kh_Nd(Nd As String)
Dim MyRng As Range
Dim R As Integer, c As Integer, rr As Long
Set MyRng = Sheets(Sh).Range(MyND)
With Sheets(ShName)
    rr = .Range(Range_Index).Row
    c = .Range(Range_Index).Column
End With
With MyRng
    For R = 1 To .Rows.Count
       ' If .Cells(R, 1) = Nd Then
       If .Cells(R, 1) Like "*" & Nd & "*" Then
            Sheets(ShName).Cells(rr, c) = R
            rr = rr + CountRow
        End If
    Next
End With
End Sub
Sub kh_ClearContents_2()
Dim T As Long
With Sheets(ShName)
    .Range(Range_Index).ClearContents
    T = .UsedRange.Rows.Count
    .Rows(FirstRow + CountRow).Resize(T).Delete
    Application.GoTo .Range(Range_Index), True
End With
End Sub

Sub kh_Delete_2()
Application.ScreenUpdating = False
kh_ClearContents_2
Application.ScreenUpdating = True
ThisWorkbook.save
MsgBox "تم مسح الشهادات وحفظ العمل", vbMsgBoxRight, "الحمد لله"
Range("b1").Select
End Sub
Sub Kh_Search_2()
Load form_Search_2
With form_Search_2
    .Tag = Sh
    .CM_TextFind.Tag = MyNSearch
    .Show
End With
End Sub

'=========================================================
'=========================================================
Sub AddPageBreaks()
    Dim R As Long, LR As Long
    LR = ورقة12.[A5000].End(xlUp).Row
    ActiveSheet.ResetAllPageBreaks
    For R = (5 + 49) To LR Step 48
        ActiveSheet.HPageBreaks.Add Before:=Cells(R, 1)
    Next
'Set ActiveSheet.HPageBreaks(1).Location = Range("B6")
End Sub

 

شهادات بطريقه العلامه باقشير.rar

[ARAMIT]

On ٣٠‏/٣‏/٢٠١٣ at 9:16 AM, محمدي عبد السميع said:

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

أما بعد:
رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته
ولذا
رأيت أنا الفقير إلى الله
المحمدي عبد السميع عبد الغني

وهو عباره عن ملف رائع لاستخراج

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

 

أوائل الطلبه وشهادات3.rar

بسم الله تعالى

ارجو من الله العز وجل ان يوفقكم على كل عمل خير ويجعله في ميزان حسناتكم

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

 

 

 

[ناصر سعيد]

الاستاذ الكبير / خالد الرشيدي

يحفظك الله ويرعاك  ..

هذا ملفي لااستطيع تعديله بطريقتك  التي اعجبتني في المشاركه السابقه

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

الاجابه للاستاذ الكبير خالد الرشيدي

السلام عليكم

اخى ناصر ان كنت تقصد الفورم المسمي   Form_Search     يمكنك ان تستبدل هذا الجزء

 If Mycell Like "*" & CM_TextFind.Text & "*" Then

بهذا السطر عله طلبك 

 If Mycell Like  CM_TextFind.Text & "*" Then

 

[ناصر سعيد]

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

تحسينات في كود البحث للمحترم خالد الرشيدي

شهادات بطريقه النابغه العلامه باقشير1.rar

[ناصر سعيد]

تكوين فصول روعه

 

[ناصر سعيد]

 

[ناصر سعيد]

شرح عمل الشهادات للنابغه ساجده العزاوي

 

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

رابط ملف التطبيق
http://www.mediafire.com/file/jdte1oy

[ناصر سعيد]

 

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

تم نشره في 24‏/08‏/2017

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

[ناصر سعيد]

•  

• ارسل تقرير عن المشاركه
•  

قام بنشر Friday في 12:05

ملف التطبيق

http://www.mediafire.com/file/yr1rrb7...

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

http://gulfup.co/itpyj0db0zzp

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

رابط اخر

https://up.top4top.net/downloadf-644qz4ck1-rar.html

 

 

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

Sub sajida()
'===================
'هذا الكود للنابغه ساجدة العزاوي
'الهدف من الكود هو استخراج وطباعه شهادات الناجحين
'كل 4 شهادات في صفحه واحده
'تم هذا الكود في 6/10/2017
'=*=*=*=*=*=*=*
 Dim SHehada As Worksheet, DATA As Worksheet, Z As Range
    Set DATA = Worksheets("رصد الترم الثانى")    'اسم شيت قاعدة البيانات
    Set SHehada = Worksheets("4شهادات")    'اسم الشيت الخاص بالشهادات
    Dim myArray, targt
    targt = "ناج*"    'خلية البحث
   Set Z = SHehada.Range("M3")
'===================
c = 0
Application.ScreenUpdating = False
    lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row   'اخر صف به بيانات

' عدد الصفوف الخارجة عن التوزيع في ورقة مصدر البيانات
    For i = 7 To lr
    '=======
     If DATA.Cells(i, 101) Like targt & "*" And c = 0 Then

          '  If (DATA.Cells(i, 101) = "ناجــــح" Or DATA.Cells(i, 101) = "ناجحــــة") And c = 0 Then
     Z = DATA.Cells(i, 2)
            c = c + 1
            '===
           ' ElseIf (DATA.Cells(i, 101) Like "*" & "ناج" & "*" And c = 1 Then
   ElseIf DATA.Cells(i, 101) Like targt & "*" And c = 1 Then
     SHehada.Range("M19") = DATA.Cells(i, 2)
            c = c + 1
           ' ElseIf (DATA.Cells(i, 101) = "ناجــــح" Or DATA.Cells(i, 101) = "ناجحــــة") And c = 2 Then
   ElseIf DATA.Cells(i, 101) Like targt & "*" And c = 2 Then

     SHehada.Range("M35") = DATA.Cells(i, 2)
            c = c + 1
           ' ElseIf (DATA.Cells(i, 101) = "ناجــــح" Or DATA.Cells(i, 101) = "ناجحــــة") And c = 3 Then
   ElseIf DATA.Cells(i, 101) Like targt & "*" And c = 3 Then

     SHehada.Range("M51") = DATA.Cells(i, 2)
            c = c + 1
            End If
            
    If i = lr And c = 4 Then SHehada.Range("a1:p63").PrintOut: Exit For
    If i = lr And c = 3 Then SHehada.Range("a1:p47").PrintOut: Exit For
    If i = lr And c = 2 Then SHehada.Range("a1:p31").PrintOut: Exit For
    If i = lr And c = 1 Then SHehada.Range("a1:p15").PrintOut: Exit For
    If i < lr And (SHehada.Range("M19") = "" Or SHehada.Range("M35") = "" Or SHehada.Range("M51") = "") Then GoTo 1
    If i < lr And c = 4 Then SHehada.Range("a1:p63").PrintOut
      c = 0
     Z = ""
     SHehada.Range("M19") = ""
     SHehada.Range("M35") = ""
     SHehada.Range("M51") = ""
    
1:
   Next i
     Z = ""
     SHehada.Range("M19") = ""
     SHehada.Range("M35") = ""
     SHehada.Range("M51") = ""
   Application.ScreenUpdating = True
End Sub

 

[ناصر سعيد]

 

[ناصر سعيد]