طباعه 4 شهادات في صفحه واحده

[ابن بنها]

ملف التطبيق

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

 

[ابن بنها]

يظهر عندي هذه الصوره عند فتح الملف ... لماذا ارجوكم ؟

===========

اريد رفع الملف مضبوطا على موقع اخر او على المنتدى افضل

[ابن بنها]

ربنا يبارك فيكم يارب

 

[ناصر سعيد]

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

هذا هو الملف وهذا هو الكود

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

'=*=*=**=*=*=*=*=*

 

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

http://gulfup.co/itpyj0db0zzp

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

رابط اخر

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