أخي الكريم
أين المشكلة؟ أين السؤال؟ أين التفاصيل؟ أين شكل النتائج المتوقعة؟!!!
للأسف رغم كل التوجيهات التي نقدمها في كل الأسئلة والموضوعات ، ما زال الأعضاء يصرون على عدم توضيح السؤال .. وهذا للأسف يجعل الأعضاء ينفرون من المنتدى ولا يقدمون على مساعدة الآخرين.

السلام عليكم أستاذ ياسر
عذرا
كود ترحيل كل مستوى إلى جدوله الخاص موجود في الموديل 02 و عند تنفيذه يظهر الخطأ المضلل باللون الأصفر في الصورة المرفقة سابقا أما عن النتائج المتوقعة فهي :

لم أفهم على أي أساس يتم الترحيل إلى ثلاثة جداول .. ما هو المعيار أو الشرط لعمليات الترحيل؟

عموماً جرب التعديل التالي عله يكون المطلوب

Sub Filter_Class()
    If ActiveSheet.Name <> "TI3DAD" 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("TI3DAD")
    Set D1 = CreateObject("Scripting.Dictionary")
    Set D2 = CreateObject("Scripting.Dictionary")
    Set D3 = CreateObject("Scripting.Dictionary")
    With f
        .Range("M4").CurrentRegion.ClearContents
        .Range("X4").CurrentRegion.ClearContents
        .Range("AI4").CurrentRegion.ClearContents
        I = 5
        Do Until I = 29
            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 = 4
        If D3.Count Then
            For Each ky In D3
                .Cells(m, "M").Resize(, 13) = Split(D3(ky), "*")
                m = m + 1
            Next ky
        End If
        m = 4
        If D2.Count Then
            For Each ky In D2
                .Cells(m, "X").Resize(, 13) = Split(D2(ky), "*")
                m = m + 1
            Next ky
        End If
        m = 2
        If D1.Count Then
            For Each ky In D1
                .Cells(m, "AI").Resize(, 13) = 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("AI5").CurrentRegion.Value = .Range("AI5").CurrentRegion.Value
    End With
End Sub

تم المطلوب بنجاح ألف تحية و شكر أستاذ ياسر

بارك الله فيك أخي الكريم
والحمد لله الذي بنعمته تتم الصالحات.