مشكلة في كود الترحيل

[مجاهد2013]

السلام عليكم إخوتي و أساتذتي الكرام

في الملف المرفق أريد ترحيل تعداد التلاميذ حسب الجدول كلاً إلى مستواه

مثلا : 4م1 - 4م2  -........الى جدول السنة الرابعة 

   3م1 - 3م2  -.........الى جدول السنة الثالثة

2م1 - 2م2  -.........الى جدول السنة الثانية

1م1 - 1م2  -.........الى جدول السنة الأولى

كود الترحيل مع الملف هو لأحد أساتذة المنتدى جزاه الله خيرا كنت قد استعملته مع ثلاث مستويات و بعد الاضافة لم أتمكن من معرفة الخلل.

تعداد.xlsm

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

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

اليك التصحيج

 

Sub Filter_Class2()

Dim WSdest As Worksheet: Set WSdest = Sheets("TI3DAD")
Dim D1 As Object, D2 As Object, D3 As Object, D4 As Object
Dim I As Long, x As Long, Y As Long, m As Long, z As Long
Dim Réf As Variant, ky As Variant, Rng As String

Set D1 = CreateObject("Scripting.Dictionary")
Set D2 = CreateObject("Scripting.Dictionary")
Set D3 = CreateObject("Scripting.Dictionary")
Set D4 = CreateObject("Scripting.Dictionary")

x = 0: Y = 0: m = 0: z = 0

With WSdest
    Application.ScreenUpdating = False
    
    .Range("M4:V32,X4:AG32,AI4:AR32,AT4:BC32").ClearContents
    
    I = 7
    Do While I <= .Rows.Count
        If .Cells(I, 2) <> "" Then
            Rng = Left(Trim(.Cells(I, 2).Value), 1)
            
            Réf = Application.Transpose(.Cells(I, 2).Resize(, 13).Value)
            Réf = Application.Transpose(Réf)
            
            Select Case Rng
                Case "4"
                    D4(z) = Join(Réf, "*")
                    z = z + 1
                Case "3"
                    D3(Y) = Join(Réf, "*")
                    Y = Y + 1
                Case "2"
                    D2(x) = Join(Réf, "*")
                    x = x + 1
                Case "1"
                    D1(m) = Join(Réf, "*")
                    m = m + 1
            End Select
            
            I = I + 1
        Else
            Exit Do
        End If
    Loop
    
    m = 4
    If D4.Count > 0 Then
        For Each ky In D4.Keys
            .Cells(m, "M").Resize(, 13).Value = Split(D4(ky), "*")
            m = m + 1
        Next ky
    End If
    
    m = 4
    If D3.Count > 0 Then
        For Each ky In D3.Keys
            .Cells(m, "X").Resize(, 13).Value = Split(D3(ky), "*")
            m = m + 1
        Next ky
    End If
    
    m = 4
    If D2.Count > 0 Then
        For Each ky In D2.Keys
            .Cells(m, "AI").Resize(, 13).Value = Split(D2(ky), "*")
            m = m + 1
        Next ky
    End If
    
    m = 4
    If D1.Count > 0 Then
        For Each ky In D1.Keys
            .Cells(m, "AT").Resize(, 13).Value = Split(D1(ky), "*")
            m = m + 1
        Next ky
    End If
    
    .Range("M4").CurrentRegion.Value = .Range("M4").CurrentRegion.Value
    .Range("X4").CurrentRegion.Value = .Range("X4").CurrentRegion.Value
    .Range("AI4").CurrentRegion.Value = .Range("AI4").CurrentRegion.Value
    .Range("AT4").CurrentRegion.Value = .Range("AT4").CurrentRegion.Value
    
    Application.ScreenUpdating = True
End With


End Sub

1تعداد.xlsm

[مجاهد2013]

تمام استاذ عبد الله الف شكر  تحياتي لك