شهادات نصف العام للصف الثالث الابتدائى

[أبو عرابى]

بسم الله الرحمن الرحيم

الاخوة والاخوات الكرام / مشرفى واعضاء المنتدى الكرام

السلام عليكم ورحمة الله وبركاته

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

ولكم جزيل الشكر

دمج.xlsx

[سليم حاصبيا]

جرب هذا الكود

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

Option Explicit
Private Sub Worksheet_Activate()
FIL_CDATA_VAL
End Sub
 '++++++++++++++++++++++++++++++++++++++++++++++++
 Sub FIL_CDATA_VAL()
    Dim i As Long: i = 8
  Dim DIC As Object
   Set DIC = CreateObject("Scripting.Dictionary")

Do Until Sheets("DATA").Range("C" & i) = vbNullString
    DIC(Sheets("DATA").Range("C" & i).Value) = ""
    i = i + 1
Loop
 
 With Sheets("RESULT").Range("k5").Validation
    .Delete
    .Add 3, Formula1:=Join(DIC.KEYS, ",")
 End With
 Set DIC = Nothing
End Sub
'++++++++++++++++++++++++++++++++++++++++
Sub GET_CERTIFICAT()
Dim dat As Worksheet, RES As Worksheet
Dim Num%, k%, R, i%, Found_Ro%, Ro%: Ro = 8
Dim FOUND_RG As Range
Dim n: n = 3
Dim arr
Set dat = Sheets("DATA"): Set RES = Sheets("RESULT")
Union(RES.Range("c5"), RES.Range("c19"), RES.Range("c33")) = vbNullString
Union(RES.Range("c8:k9"), RES.Range("c22:k23"), RES.Range("c36:k37")) = vbNullString

Num = RES.Range("K5")
arr = Array(2, 5, 7, 9, 11, 13, 15, 17, 19, 21)
For k = 1 To n
 Set FOUND_RG = dat.Range("a8").CurrentRegion.Columns(3). _
 Find(Num, LOOKAT:=1)
 If FOUND_RG Is Nothing Then Exit Sub
 R = FOUND_RG.Row
   RES.Cells(Ro - 3, 3) = dat.Cells(R, arr(0))
      For i = 1 To UBound(arr)
        With RES.Cells(Ro, 3).Offset(, i - 1)
          .Value = dat.Cells(R, arr(i))
          .Offset(1) = dat.Cells(R, arr(i) + 1)
        End With
      Next
      RES.Cells(Ro + 2, 3) = dat.Cells(R, 23)
     Num = Num + 1: Ro = Ro + 14
Next
End Sub

الملف مرفق

RESULT.xlsm

[عبدالله الصاري]

استاذنا  الفاضل

يبدو انك نسيت ارفاق الملف

في انتظارة للتعلم والاستفاذة

شكرا على ارفاق الملف

تم تعديل يناير 3, 2020 بواسطه عبدالله الصاري

[سليم حاصبيا]

تمت اضافته الى المشاركة

[أبو عرابى]

بارك الله فيك استاذنا الفاضل ويتبقى اسم المحافظة والادارة والمدرسة وتذيل الشهادة 

[سليم حاصبيا]

هذه الاشياء يمكنك كتابتها يدوياً لمرة واحدة فقط