أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
هانى على ali mohamed ali-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة منع ادخال البيانات بعدة شروط اكسيل اسئله واجابات


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





كود طباعة الشهادات

السلام عليكم ورحمة الله وبركاته المطلوب كود لطباعة الشهائد


موضوع مغلق


20-11-2020 10:36 صباحا
Khairi
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 11-11-2017
رقم العضوية : 1466
المشاركات : 181
الجنس : ذكر
تاريخ الميلاد : 20-12-1973
يتابعهم : 7
يتابعونه : 6
قوة السمعة : 116
 offline 

السلام عليكم ورحمة الله وبركاته
المطلوب كود لطباعة الشهائد
 
 
  طباعة الشهائد.xlsm   تحميل xlsm مرات التحميل :(5)
الحجم :(649.126) KB



أفضل إجابة مقدمة من salim وهي:

1-تصغير الملف الى 20 - 40 اسم لا أكثر

تختار الأرقام من الخليتين B1 و  B2 (في حال الخطأ الماكرو ياخذ الأرقام من 1 الى عدد الطلاب)

2- في حال تريد طالباً واحداَ تكرر رقمه في B1 و  B2    مثلاً نريد الطالب رقم 5 نضع  5=B1 و  5=B2

يوجد صفحة مخفية لادراج الجداول (عدم المس بها لحسن سير عمل الماكرو)

جرب هذا الملف


Dim Mn%, Mx%, LR, k%, t%, i%
Dim ValA, ValB
Dim xx1%, xx2%
Rem Created By Salim On 20/11/2020
Sub CopY_rg(rg As Range, Where%)
rg.Copy
Saf.Range("A" & Where).PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
End Sub
'++++++++++++++++++++++++++++++++
Sub fil_Rg()
Rem Created By Salim  On 20/11/2020
LR = Fat.Cells(Rows.Count, 3).End(3).Row
If LR < 10 Then Exit Sub
xx1 = Val(Fat.Range("B1"))
xx2 = Val(Fat.Range("B2"))
ValA = IIf(xx1 <= 0, 1, Int(xx1))
ValB = IIf(xx2 <= 0, LR - 9, Int(xx2))

If ValA > LR - 9 Then ValA = 1
If ValB > LR - 9 Then ValB = LR - 9
Mn = Application.Min(ValA, ValB)
Mx = Application.Max(ValA, ValB)
Fat.Range("B1") = Mn: Fat.Range("B2") = Mx
t = Fat.Range("B2") - Fat.Range("B1") + 1
k = 1
Saf.Cells.Clear
For i = 1 To t
 Call CopY_rg(Source.Range("SPES_RG"), k)
 k = k + 18
 Next
 Saf.Rows.AutoFit
End Sub
'++++++++++++++++++++++++++++++++++
Sub Get_certificates()
Rem Created By Salim  On 20/11/2020
fil_Rg
Dim Ro1%, Ro2%, Pos%
Dim y%, n%
Dim A1, A2, A3
A1 = Application.Transpose(Source.Range("Q1:AA1"))
A1 = Application.Transpose(A1)
A2 = Application.Transpose(Source.Range("Q2:AA2"))
A2 = Application.Transpose(A2)
A3 = Application.Transpose(Source.Range("Q3:AA3"))
A3 = Application.Transpose(A3)
Pos = 8
Ro1 = Fat.Range("B1") + 9
Ro2 = Fat.Range("B2") + 9
 For y = Ro1 To Ro2
   Saf.Cells(Pos - 6, 3) = Fat.Cells(y, 3)
 For n = LBound(A1) To UBound(A1)
  If Saf.Cells(Pos, 1) = "" Then Exit For
      Saf.Cells(Pos, 3).Offset(, n - 1) = _
         Fat.Cells(y, A1(n))
      Saf.Cells(Pos, 3).Offset(1, n - 1) = _
         Fat.Cells(y, A2(n))
      Saf.Cells(Pos, 3).Offset(2, n - 1) = _
         Fat.Cells(y, A3(n))
  Next n
  Pos = Pos + 18
 Next y
  Saf.PageSetup.PrintArea = Saf.Range("a1") _
 .Resize(Pos - 10, 14).Address
End Sub

الملف مرفق
 
عرض الإجابة




20-11-2020 06:21 مساء
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif كود طباعة الشهادات

1-تصغير الملف الى 20 - 40 اسم لا أكثر

تختار الأرقام من الخليتين B1 و  B2 (في حال الخطأ الماكرو ياخذ الأرقام من 1 الى عدد الطلاب)

2- في حال تريد طالباً واحداَ تكرر رقمه في B1 و  B2    مثلاً نريد الطالب رقم 5 نضع  5=B1 و  5=B2

يوجد صفحة مخفية لادراج الجداول (عدم المس بها لحسن سير عمل الماكرو)

جرب هذا الملف


Dim Mn%, Mx%, LR, k%, t%, i%
Dim ValA, ValB
Dim xx1%, xx2%
Rem Created By Salim On 20/11/2020
Sub CopY_rg(rg As Range, Where%)
rg.Copy
Saf.Range("A" & Where).PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
End Sub
'++++++++++++++++++++++++++++++++
Sub fil_Rg()
Rem Created By Salim  On 20/11/2020
LR = Fat.Cells(Rows.Count, 3).End(3).Row
If LR < 10 Then Exit Sub
xx1 = Val(Fat.Range("B1"))
xx2 = Val(Fat.Range("B2"))
ValA = IIf(xx1 <= 0, 1, Int(xx1))
ValB = IIf(xx2 <= 0, LR - 9, Int(xx2))

If ValA > LR - 9 Then ValA = 1
If ValB > LR - 9 Then ValB = LR - 9
Mn = Application.Min(ValA, ValB)
Mx = Application.Max(ValA, ValB)
Fat.Range("B1") = Mn: Fat.Range("B2") = Mx
t = Fat.Range("B2") - Fat.Range("B1") + 1
k = 1
Saf.Cells.Clear
For i = 1 To t
 Call CopY_rg(Source.Range("SPES_RG"), k)
 k = k + 18
 Next
 Saf.Rows.AutoFit
End Sub
'++++++++++++++++++++++++++++++++++
Sub Get_certificates()
Rem Created By Salim  On 20/11/2020
fil_Rg
Dim Ro1%, Ro2%, Pos%
Dim y%, n%
Dim A1, A2, A3
A1 = Application.Transpose(Source.Range("Q1:AA1"))
A1 = Application.Transpose(A1)
A2 = Application.Transpose(Source.Range("Q2:AA2"))
A2 = Application.Transpose(A2)
A3 = Application.Transpose(Source.Range("Q3:AA3"))
A3 = Application.Transpose(A3)
Pos = 8
Ro1 = Fat.Range("B1") + 9
Ro2 = Fat.Range("B2") + 9
 For y = Ro1 To Ro2
   Saf.Cells(Pos - 6, 3) = Fat.Cells(y, 3)
 For n = LBound(A1) To UBound(A1)
  If Saf.Cells(Pos, 1) = "" Then Exit For
      Saf.Cells(Pos, 3).Offset(, n - 1) = _
         Fat.Cells(y, A1(n))
      Saf.Cells(Pos, 3).Offset(1, n - 1) = _
         Fat.Cells(y, A2(n))
      Saf.Cells(Pos, 3).Offset(2, n - 1) = _
         Fat.Cells(y, A3(n))
  Next n
  Pos = Pos + 18
 Next y
  Saf.PageSetup.PrintArea = Saf.Range("a1") _
 .Resize(Pos - 10, 14).Address
End Sub

الملف مرفق
 
 
 
  Khiri.xlsm   تحميل xlsm مرات التحميل :(12)
الحجم :(604.42) KB




الكلمات الدلالية
طباعة ، الشهائد ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 12:22 صباحا