كود ترحيل البيانات الي الشهادات

[aboesa]

السلام عليكم : اريد كود ترحيل البيانات من data الي الشهادات حسب فئة الفصل الموجود في الخلية F2 .مع زيادة عدد الشهادات حسب عدد الفصل .مع الشرح والتوضيح. بارك الله فيكم 

طباعة شهادات.xlsm

[وجيه شرف الدين]

اتفضل الملف لعله يفى بالغرض

نسخة من طباعة شهادات.xlsm

[aboesa]

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

[وجيه شرف الدين]

جزاكم الله خير ولكم بمثل ما دعوت

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

بعد اذن الاخ وحيه

هذا الماكرو

Option Explicit
Sub Get_Blanks()
 With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim Pr As Worksheet
Dim Da As Worksheet
 Set Pr = Sheets("Print")
 Set Da = Sheets("Data")

Dim LR_Pr%, k%
Dim separator%: separator = 14
If IsError(Application.Match(Pr.Range("f2"), Da.Range("G:G"), 0)) Then
  MsgBox "Wrong name of Section"
  Pr.Range("A14:f5000").Clear
  GoTo Exit_Sub
End If
  Dim x%: x = Application.CountIf(Da.Range("G:G"), Pr.Range("f2"))
     LR_Pr = Pr.Cells(Rows.Count, "b").End(3).Row
      If LR_Pr > 13 Then
       Pr.Range("a14").Resize(LR_Pr, 6).Clear
      End If
    For k = 1 To x - 1
     Pr.Range("PRINCE_RG").Copy
     Pr.Range("a" & separator).PasteSpecial
     separator = separator + 14
    Next
     Application.CutCopyMode = False
     
     fill_data
     Pr.Range("c4").Select
Exit_Sub:
      With Application
     .ScreenUpdating = True
     .Calculation = xlCalculationAutomatic
      End With
End Sub
Rem====================================
 Sub fill_data()

 Dim col_Dt As New Collection
 Dim Pt As Worksheet: Set Pt = Sheets("Print")
 Dim Dt As Worksheet: Set Dt = Sheets("Data")
 Dim First_Row_dt%, Fix_Row_dt%
 Dim find_rng As Range
 Dim kk%: kk = 4
 Dim Collec_num%
   
   Set find_rng = Dt.Range("g:g").Find(Pt.Range("f2"))
    If Not find_rng Is Nothing Then
     Fix_Row_dt = find_rng.Row: First_Row_dt = Fix_Row_dt
     col_Dt.Add Dt.Cells(Fix_Row_dt, 1).Value
     Do
       Set find_rng = Dt.Range("g:g").FindNext(find_rng)
        Fix_Row_dt = find_rng.Row
        If First_Row_dt = Fix_Row_dt Then Exit Do
         col_Dt.Add Dt.Cells(Fix_Row_dt, 1).Value
     Loop
      End If
      For Collec_num = 1 To col_Dt.Count
        Pt.Range("c" & kk) = col_Dt(Collec_num)
       kk = IIf(kk < 15, kk + 13, kk + 14)
       Next
       Set col_Dt = Nothing
 End Sub

الملف مرفق

 

Print_Shahadat.xlsm

[Ali Mohamed Ali]

بارك الله فيكم جميعا كلها حلول ممتازة

[aboesa]

حبيبي الاستاذ سليم بارك الله فيك وزادك من علمه

[وجيه شرف الدين]

الله عليك استاذ سليم انت رائع ومبدع جزاكم الله خير

[احمد بدره]

بارك الله فيك أستاذ سليم وأستاذ وجيه

[وجيه شرف الدين]

2 دقائق مضت, احمد بدره said:

بارك الله فيك أستاذ سليم وأستاذ وجيه

جزاكم الله خير استاذ احمد مرورك العطر هذا