ترحيل كل صف إلى الجدول الخاص به

[مجاهد2013]

السلام عليكم
في الملف المرفق من التعداد العام اريد ترحيل كل مستوى إلى الجدول الخاص به
مثلا : 3ت ر/هم و 3ع ت03 و 3أ ف01 إلى جدول السنة الثالثة
2ع ت01 و 2أ ف01 و 2ت ر/هك إلى جدول السنة الثانية
ج م ع تك 01و ج م ع تك05 و جم أ 02 و ج م أ03 إلى جدول السنة الأولى (السنة الاولى ترتب ج م ع تك ثم ج م أ )
و شكرا مسبقا

التعداد.xlsx

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

أكثر من مرة أكرر انه لا يجوز ان يكون في جداول الاكسل خلايا مدمجة ويكون مستقلاً عن اي بيانات اخرى (ليس فقط في ازمة كورونا بل                                                                                                   في كل الأحوال)

تم ادراج صف فارغ لتحييد الجدول (الصف رقم 6)

الماكرو

Option Explicit

Sub Filter_Class()
If ActiveSheet.Name <> "Feuil1" Then Exit Sub
  Dim F As Worksheet
  Dim D1 As Object, D2 As Object, D3 As Object
  Dim i%, a As Boolean, b As Boolean, c As Boolean
  Dim x%, y%, m%, z%, arr, ky
  Dim st$
  
  Set F = Sheets("Feuil1")
  Set D1 = CreateObject("Scripting.Dictionary")
  Set D2 = CreateObject("Scripting.Dictionary")
  Set D3 = CreateObject("Scripting.Dictionary")
With F
.Range("P7").CurrentRegion.ClearContents
.Range("Ad7").CurrentRegion.ClearContents
.Range("P27").CurrentRegion.Offset(1).ClearContents

    i = 8
    Do Until i = 39
        st = Mid(Trim(.Cells(i, 2)), 1, 1)
          Select Case st
            Case "3": a = True: b = False: c = False
            Case "2": b = True: a = False: c = False
            Case Else: b = False: a = False: c = True
          End Select
        arr = Application.Transpose(.Cells(i, 2).Resize(, 13))
        arr = Application.Transpose(arr)
              
        If a Then
            D3(z) = Join(arr, "*"): z = z + 1
        ElseIf b Then
            D2(y) = Join(arr, "*"): y = y + 1
        Else
            D1(x) = Join(arr, "*"): x = x + 1
        End If
        i = i + 1
    Loop
 m = 7
 If D3.Count Then
  For Each ky In D3
  .Cells(m, "P").Resize(, 13) = Split(D3(ky), "*")
  m = m + 1
  Next ky
 End If
m = 7
If D2.Count Then
  For Each ky In D2
  .Cells(m, "AD").Resize(, 13) = Split(D2(ky), "*")
  m = m + 1
  Next ky
 End If
m = 27
If D1.Count Then
  For Each ky In D1
   .Cells(m, "P").Resize(, 13) = Split(D1(ky), "*")
   m = m + 1
   Next ky

End If
.Range("P7").CurrentRegion.Value = _
  .Range("P7").CurrentRegion.Value
.Range("Ad7").CurrentRegion.Value = _
  .Range("Ad7").CurrentRegion.Value
.Range("P27").CurrentRegion.Value = _
  .Range("P27").CurrentRegion.Value

End With
End Sub

الملف مرفق

 

 

Te3dad.xlsm

[مجاهد2013]

معذرة أستاذ و ألف ألف شكر