اذهب الي المحتوي
أوفيسنا

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

محمدي عبد السميع
 مشاركة

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

  • 2 months later...
  • الردود 65
  • Created
  • اخر رد

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

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

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

ARAMIT
ARAMIT
حسين شاكر
حسين شاكر

رائع واكثر من رائع اكرمك الله وادخلك جناته  اخى محمدي عبد السميع عبد الغني واستاذنا الفاضل ادام الله عمره وعلمه عبد الله باقشير         الملف بصيغة 2003   أوائل الطلبه وشهادات3.rar

ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر

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

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

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

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

 

 

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

==========

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

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

  • 2 weeks later...
ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر

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



'***********************************************
'***********************************************
'     اسم ورقة الشهادات
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

ARAMIT

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

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

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

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

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

 

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

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

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

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

 

 

 

  • Like 2
  • 4 weeks later...
ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر

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

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

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

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

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

السلام عليكم

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

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

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

 If Mycell Like  CM_TextFind.Text & "*" Then

 

  • 2 weeks later...
  • 1 month later...
  • 3 weeks later...
  • 3 weeks later...
ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر

 

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

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

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

  • 1 month later...
ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر
  •  

 

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



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

 

  • Like 1
  • 2 weeks later...
  • 3 weeks later...
زائر
هذا الموضوع مغلق.
 مشاركة
الذهاب الي قائمه المواضيع

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه


×
×
  • اضف...

Important Information

  I accept