ممكن تعديل على الكود

[مجاهد2013]

السلام عليكم إخوتي 

لدي في الملف المرفق في شيت TI3DAD كان يعمل جيدا و لكن بعد إضافة صفوف جديدة في شيت BASE توقف عن العمل , اصبح تظهر الرسالة المرفقة 

الكود المستعمل هو لأحد أساتذة المنتدى تشكراتي الخالصة له 

الكود موجود في Module2 - Sub filter Clas

تقرير المصلحة البيداغوحية111.xlsm

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

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

ضف هذا السطر قبل الخطأ مباشرة

            On Error Resume Next
            st = Mid(Trim(.Cells(i, 2)), 1, 1)
 

[محمد هشام.]

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

هناك حل اخر ممكن ايضا جعل الكود بهده الطريقة 

Sub Filter_Class2()

Dim WSdest As Worksheet: Set WSdest = Sheets("TI3DAD")
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%, Réf, ky, Rng$
Set D1 = CreateObject("Scripting.Dictionary"): Set D2 = CreateObject("Scripting.Dictionary")
Set D3 = CreateObject("Scripting.Dictionary")
    
  With WSdest
  Application.ScreenUpdating = False
   WSdest.Range("M4:V32,X4:AG32,AI4:AR32").ClearContents

i = 7
Do While i <= .Rows.Count
If WSdest.Cells(i, 2) <> "" And WSdest.Cells(i, 2) <> HasFormula Then

       Rng = Mid(Trim(WSdest.Cells(i, 2)), 1, 1)
            Select Case Rng
                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
            Réf = Application.Transpose(.Cells(i, 2).Resize(, 13))
            Réf = Application.Transpose(Réf)
            If a Then
                D3(z) = Join(Réf, "*"): z = z + 1
            ElseIf b Then
                D2(Y) = Join(Réf, "*"): Y = Y + 1
            Else
                D1(x) = Join(Réf, "*"): x = x + 1
            End If
            i = i + 1
        Else
Exit Do
End If
Loop
m = 4
If D3.Count Then
            For Each ky In D3
                WSdest.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
                WSdest.Cells(m, "X").Resize(, 13) = Split(D2(ky), "*")
                m = m + 1
            Next ky
        End If
m = 4
If D1.Count Then
            For Each ky In D1
               WSdest.Cells(m, "AI").Resize(, 13) = Split(D1(ky), "*")
                m = m + 1
            Next ky
         End If
        WSdest.Range("M4").CurrentRegion.Value = WSdest.Range("M4").CurrentRegion.Value
        WSdest.Range("X4").CurrentRegion.Value = WSdest.Range("X4").CurrentRegion.Value
        WSdest.Range("AI4").CurrentRegion.Value = WSdest.Range("AI4").CurrentRegion.Value
   End With
    
End Sub

 

تقرير المصلحة.xlsm

[مجاهد2013]

ألف شكر لجميع أساتذنا لحل هذة المشكلة تحياتي لكم