كود لا يعمل مع Office 365 App for interprise

[علي المصري]

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

منذ فترة طلبت من حضراتكم كون بحيث يقوم رترتيب البيانات ومن ثم ايجاد اسماء المدارس الخمسة الاوئل ووضعها في خلايا معينة

وقدم لي الاستاذ سليم حاصبيا  كود لذلك وكان يعمل جيدا

لكن الحين تم ترقية الاجهزة لدينا في المدرسة الى  Office 365 App for interprise 
واصبح الكود يعطي خطا في السطر    Set Col = CreateObject("System.Collections.ArrayList")
 

Sub FirstFive_New()
'On Error Resume Next
    Dim sh As Worksheet
    Dim sh1 As Worksheet
    Dim My_rg As Range
    Dim F_rg As Range, xx As Long
    Dim ro As Long, i As Long, a%
    Dim k As Byte, m As Byte
    Dim Cret1, Cret2
    Dim Col As Object, Dic As Object
    Dim Lt, t%, Ar_count, y, kk%
    Dim Mn, A_arr()
 Application.ScreenUpdating = False


If Range("AB3").Value = "ABCDEF" Then
    Columns("D").EntireColumn.Hidden = True
    Columns("F").EntireColumn.Hidden = True
    Columns("H").EntireColumn.Hidden = True
    Columns("J").EntireColumn.Hidden = False
    Columns("K").EntireColumn.Hidden = False
    Columns("I").EntireColumn.Hidden = False
ElseIf Range("AB3").Value = "ABCDF" Then
    Columns("D").EntireColumn.Hidden = True
    Columns("F").EntireColumn.Hidden = True
    Columns("H").EntireColumn.Hidden = True
    Columns("J").EntireColumn.Hidden = False
    Columns("K").EntireColumn.Hidden = True
    Columns("I").EntireColumn.Hidden = False
ElseIf Range("AB3").Value = "ABBBCCF" Then
    Columns("F").EntireColumn.Hidden = False
    Columns("H").EntireColumn.Hidden = False
    Columns("D").EntireColumn.Hidden = True
    Columns("J").EntireColumn.Hidden = True
    Columns("K").EntireColumn.Hidden = True
    Columns("I").EntireColumn.Hidden = True
Else
    Columns("D").EntireColumn.Hidden = False
    Columns("F").EntireColumn.Hidden = False
    Columns("H").EntireColumn.Hidden = False
    Columns("J").EntireColumn.Hidden = False
    Columns("K").EntireColumn.Hidden = False
    Columns("I").EntireColumn.Hidden = False


End If



  Set sh = Sheets("DataT1")
  Set sh1 = Sheets("FirstFiveT1")
  Set My_rg = sh.Range("A1").CurrentRegion
  Set Col = CreateObject("System.Collections.ArrayList")
  Set Dic = CreateObject("Scripting.Dictionary")
  sh1.Range("C8:C13").ClearContents
  
  ro = My_rg.Rows.Count
  sh.Cells(2, 1).Resize(ro - 1, 12).Interior.ColorIndex = xlNone
'  If sh1.Range("V8") = "" Then GoTo 1  'sh1.Range("V8") = "Grade 1"
'  If sh1.Range("V7") = "" Then sh1.Range("V7") = "Arabic Language"
  Cret1 = sh1.Range("V8"): Cret2 = sh1.Range("V7")

 If sh.FilterMode Then
 My_rg.AutoFilter
End If

My_rg.AutoFilter Field:=1, _
    Criteria1:=Cret1
My_rg.AutoFilter Field:=3, _
    Criteria1:=Cret2
      Set My_rg = My_rg.Columns(13) _
     .Resize(ro - 1).SpecialCells(12)
     Mn = Application.Large(My_rg, 5)

  Ar_count = My_rg.Areas.Count
    
    For y = 2 To Ar_count
       For kk = 1 To My_rg.Areas(y).Rows.Count
            ReDim Preserve A_arr(a)
             A_arr(a) = _
             My_rg.Areas(y).Cells(kk)
            a = a + 1
        Next kk
   Next y

 If a = 0 Then Exit Sub

    For i = LBound(A_arr) To UBound(A_arr)
        If IsNumeric(A_arr(i)) Then
         Col.Add Val(A_arr(i))
        End If
    Next i

 Col.Sort
 Col.Reverse

 For t = 0 To Col.Count - 1
  If Col(t) >= Mn Then
  Dic(Col(t)) = vbNullString
  End If
 Next


m = 8: t = 0

Do Until t = Dic.Count + 1

        Set F_rg = My_rg.Find(Dic.keys()(t) _
        , lookat:=1)
        If Not F_rg Is Nothing Then
         xx = F_rg.Row: Lt = xx
       Do
         sh.Cells(Lt, 1).Resize(, 12).Interior.ColorIndex = 6
         With sh1.Cells(m, "C")
            .Value = sh.Cells(Lt, "B")
'            .Offset(, 1).Resize(, 9).Value = _
'             sh.Cells(Lt, "D").Resize(, 9).Value
'            .Offset(, 10) = F_rg
            m = m + 1
         End With
         Set F_rg = My_rg.FindNext(F_rg)
          Lt = F_rg.Row
          If Lt = xx Then Exit Do
       Loop
         End If
         t = t + 1
         If t = Dic.Count Then Exit Do
    Loop
If sh.FilterMode Then
 My_rg.AutoFilter
End If
Application.ScreenUpdating = True
 Set sh = Nothing
 Set My_rg = Nothing: Set F_rg = Nothing
 Set Col = Nothing: Set Dic = Nothing
 Erase A_arr
 
If Range("Q12").Value = 0 Then
    Rows("12").EntireRow.Hidden = True
Else
    Rows("12").EntireRow.Hidden = False
End If
 
     Range("C8").Select
End Sub

هل يمكن حل هذه المشكلة

FirstFives.xlsb

[علي المصري]

توضيح
المفروض يتم ايجاد اعللى خمس قيم في عمود المتوسط في Data ومن ثم استخلاص اسماء المدارس المقابلة لها ثم كتابتها في النطاقة من c8 الى c13 في صفحة firstfive وهذا بناء على اختيار الشعبة والمادة في الخلية  V7 والخلية V8 في ورقة firstfive

[علي المصري]

تم التوصل للحل

عن طريق اضافة

.Net Framework 3.5

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

[عبدالفتاح في بي اكسيل]

اقتباس

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

مستحيل  ما  تطلبه  لان  هذا  جزء  من  نظام  الويندوز  ختى  تعمل  البرامج  الاخرى  بشكل  جيد  لا  بد  ان  تكون  حزمة  فريم ويرك  مثبتة بجهازك  ويفضل  اخر  اصدار  .هذه  المشكلة  لاتتعلق  باصدار  الاوفيس  لانها  حدثت  معي  في  اكسيل اصدار  2019 .

تحياتي

[علي المصري]

شكرا جزيلا