عمل كود ترحيل اسماء الطلاب مع الدرجة الى شيت مختلف الاعمدة والصفوف في الاكسل

[hasha737]

الرجاء المساعدة من عباقرة الاكسل في الموقع الرائع 

مرفق لكم النموذج للعمل

نموذج العمل على القالب.xlsx

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

البيانات كثيرة جداً  مما يجعل عملية متابعة الكود الذي سيتم وضعه  صعبة

لذلك قم بتحميل نموذح صغير عن الملف (3 أو 4 اسماء ) عن كل مادة لوضع كود مناسب و من ثم يتم تعميم هذا الكود على الملف الأصلي

[hasha737]

تسلم ياخي سليم هذا الملف الجديد (3 اسماء فقط وشكر لتفاعلك 

نموذج العمل على القالب2.xlsx

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

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

نموذج العمل على القالب.xlsx

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

جرب هذا الكود

Option Explicit
Sub give_Data()
Dim k As Byte, x%, Xera%, t%, Y%
Dim my_cel, m%: m = 2
Dim col%
Dim Filter_range As Range
 Dim Nous As Worksheet: Set Nous = Sheets("شيت نص السنة")

 Dim Kaleb As Worksheet: Set Kaleb = Sheets("قالب رفع الدرجات")
 Dim Nous_ro%: Nous_ro = Nous.Cells(Rows.Count, 1).End(3).Row
  Kaleb.Range("a2:t5000").ClearContents

 Dim Rg_Nous As Range: Set Rg_Nous = Nous.Range("a1:G" & Nous_ro)
 Dim Nous_r%: Nous_r% = Rg_Nous.Rows.Count

 Dim mY_arr(): mY_arr = Array(1, 2, 3, 4, 5, 7)
  With Nous
 If .FilterMode Then
  .ShowAllData
  .AutoFilterMode = False
 End If
   For k = 0 To 5
    Rg_Nous.AutoFilter 3, mY_arr(k)
     Set Filter_range = Rg_Nous.Offset(1, 0).Resize(Nous_r% - 1).SpecialCells(xlCellTypeVisible)
      Xera = Filter_range.Areas.Count
      For t = 1 To Xera
        Y = Filter_range.Areas(t).Rows.Count
         Kaleb.Cells(m, 1).Resize(Y, 6).Value = _
         Filter_range.Areas(t).Cells(1, 1).Resize(Y, 6).Value
          Select Case mY_arr(k)
           Case 1: col = 20
           Case 2: col = 8
           Case 3: col = 10
           Case 4: col = 14
           Case 5: col = 16
           Case 7: col = 12
          End Select
          Kaleb.Cells(m, col).Resize(Y, 1).Value = _
          Filter_range.Areas(t).Cells(1, 7).Resize(Y, 1).Value
           m = m + Y
       
     Next t
       Next k
   .AutoFilterMode = False
  End With
    give_Data1
End Sub
Rem=============================================
Sub give_Data1()
Dim k As Byte, x%, Xera%, t%, Y%
Dim my_cel, m%: m = 2
Dim col%
Dim Filter_range As Range

 Dim Shahr As Worksheet: Set Shahr = Sheets("شيت الشهري")
 Dim Kaleb As Worksheet: Set Kaleb = Sheets("قالب رفع الدرجات")

 
 Dim Shahr_ro%: Shahr_ro = Shahr.Cells(Rows.Count, 1).End(3).Row
 Dim Rg_Shahr As Range: Set Rg_Shahr = Shahr.Range("a1:G" & Shahr_ro)
 Dim mY_arr(): mY_arr = Array(1, 2, 3, 4, 5, 7)
  With Shahr
 If .FilterMode Then
  .ShowAllData
  .AutoFilterMode = False
 End If
   For k = 0 To 5
    Rg_Shahr.AutoFilter 3, mY_arr(k)
     Set Filter_range = Rg_Shahr.Offset(1, 0).Resize(Shahr_ro - 1).SpecialCells(xlCellTypeVisible)
      Xera = Filter_range.Areas.Count
      For t = 1 To Xera
        Y = Filter_range.Areas(t).Rows.Count
          Select Case mY_arr(k)
           Case 1: col = 20
           Case 2: col = 8
           Case 3: col = 10
           Case 4: col = 14
           Case 5: col = 16
           Case 7: col = 12
          End Select
          Kaleb.Cells(m, col - 1).Resize(Y, 1).Value = _
          Filter_range.Areas(t).Cells(1, 7).Resize(Y, 1).Value
           m = m + Y
       
     Next t
       Next k
   .AutoFilterMode = False
  End With
    
End Sub

الملف

simple_data.xlsm

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

دائما سباق الى الخير استاذ سليم

[hasha737]

أخي سليم أنا اريد برنامج حسب الطلب هل ممكن رقمك نتواصل