اذهب الي المحتوي
أوفيسنا

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


الردود الموصى بها

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

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

رابط هذا التعليق
شارك

جرب هذا الكود

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

  • Like 2
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information