الحصول على بيانات المدارس الثلاثة الاولى من حيث المتوسط بشرط المادة والصف

**علي المصري** · مارس 2, 2021

السلام عليكم ورحمة الله وبركاته
كيف يمكن الحصول على أسماء المدارس الثلاثة الأولى في الترتيب من الأولى إلى الثالثة من حيث المتوسط بشرط الصف والمادة الموضحين في الخليتين الملونتين بالاصفر والاخضر وعند تغيير المادة او الصف احصل على النتيجة حسب هذا التغيير

شرح اكثر داخل الملف المرفق
مع الشكر الجزيل

AliElmasry.xlsx

**سليم حاصبيا** · مارس 2, 2021

جرب هذا الماكرو (هناك ورقة مخفية مساعدة Sheet1 ) الرجاء عدم مسحها

Option Explicit
Sub First_Sec_Third()
    Dim sh As Worksheet
    Dim Aux_sh As Worksheet
    Dim My_rg As Range
    Dim F_rg As Range, xx As Long
    Dim Cret1, Cret2
    Dim ro As Long
    Dim k As Byte, m As Byte
 Application.ScreenUpdating = False
  Set Aux_sh = Sheets("Sheet1")
  Set sh = Sheets("Data")
  sh.Range("P9:Z11").ClearContents
  Set My_rg = sh.Range("A1").CurrentRegion
  
  ro = My_rg.Rows.Count
  If sh.Range("P4") = "" Then sh.Range("P4") = "Grade 1"
  If sh.Range("P3") = "" Then sh.Range("P3") = "Arabic Language"
  Cret1 = sh.Range("P4"): Cret2 = sh.Range("P3")
  
Aux_sh.Range("A1").CurrentRegion.Clear

If sh.FilterMode Then
 My_rg.AutoFilter
End If

My_rg.AutoFilter Field:=1, Criteria1:=Cret1
My_rg.AutoFilter Field:=3, Criteria1:=Cret2

My_rg.Columns(13).Offset(1).Resize(ro - 1).Copy
Aux_sh.Range("A1").PasteSpecial (12)
Aux_sh.Range("A1").CurrentRegion.SortSpecial , Order1:=2

If sh.FilterMode Then
 My_rg.AutoFilter
End If

k = 1: m = 9
    Do Until k = 4
        Set F_rg = My_rg.Find(Aux_sh.Range("A" & k), lookat:=1)
         xx = F_rg.Row
         With sh.Cells(m, "P")
            .Value = sh.Cells(xx, "B")
            .Offset(, 1).Resize(, 9).Value = _
             sh.Cells(xx, "D").Resize(, 9).Value
            .Offset(, 10) = F_rg
         End With
        k = k + 1: m = m + 1
    Loop
Application.ScreenUpdating = True
 Set sh = Nothing: Set Aux_sh = Nothing
 Set My_rg = Nothing: Set F_rg = Nothing
    
End Sub

Masry.xlsm

**علي المصري** · مارس 2, 2021

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

استاذنا الفاضل الاستاذ سليم

شكرا جزيلا على سرعة الرد والحل لهذه المشكلة

هل يمكن الاستغناء عن الورقة

sheet1

المساعدة

جزاكم الله خيرا

**سليم حاصبيا** · مارس 2, 2021

يمكن ذلك بواسطة هذا الكود

Option Explicit
Sub First_Sec_Third()
    Dim sh As Worksheet
    Dim My_rg As Range
    Dim F_rg As Range, xx As Long
    Dim ro As Long, i As Long
    Dim k As Byte, m As Byte
    Dim Cret1, Cret2
    Dim arr, Col As Object
 Application.ScreenUpdating = False


  Set sh = Sheets("Data")
   Set My_rg = sh.Range("A1").CurrentRegion
  Set Col = CreateObject("System.Collections.ArrayList")
  
  sh.Range("P9:Z11").ClearContents
  ro = My_rg.Rows.Count
  If sh.Range("P4") = "" Then sh.Range("P4") = "Grade 1"
  If sh.Range("P3") = "" Then sh.Range("P3") = "Arabic Language"
  Cret1 = sh.Range("P4"): Cret2 = sh.Range("P3")

If sh.FilterMode Then
 My_rg.AutoFilter
End If

My_rg.AutoFilter Field:=1, _
    Criteria1:=Cret1
My_rg.AutoFilter Field:=3, _
    Criteria1:=Cret2
arr = My_rg.Columns(13).Offset(1) _
     .Resize(ro - 1).SpecialCells(12)
    
    For i = 1 To UBound(arr)
     If IsNumeric(arr(i, 1)) Then Col.Add arr(i, 1)
    Next i
 
 Col.Sort
 Col.Reverse

If sh.FilterMode Then
 My_rg.AutoFilter
End If

m = 9
Do Until m = 12
        Set F_rg = My_rg.Find(Col(m - 9), lookat:=1)
         xx = F_rg.Row
         With sh.Cells(m, "P")
            .Value = sh.Cells(xx, "B")
            .Offset(, 1).Resize(, 9).Value = _
             sh.Cells(xx, "D").Resize(, 9).Value
            .Offset(, 10) = F_rg
         End With
         m = m + 1
 Loop

Application.ScreenUpdating = True
 Set sh = Nothing: Set Aux_sh = Nothing
 Set My_rg = Nothing: Set F_rg = Nothing
 Set Col = Nothing
End Sub

Masry_collcetion.xlsm

**علي المصري** · مارس 2, 2021

شكرا جزيلا

جزاكم الله خيرا

اعطاني خطا هنا

image.png.a37ac38543e64b868995b6c13b0f508d.png

انا بدلت الحين
Aux-sh

الى Col

هل هذا صحيح

**سليم حاصبيا** · مارس 2, 2021

امسح هذه العبارة بالكامل حيث لا وجود للشيت Sheet1 و يالتالي Aux_sh

Set Aux_sh = Nothing

Aux_sh

هذه العبارة موجودة Set Col = Nothing ولا لزوم لنكرارها

**سليم حاصبيا** · مارس 2, 2021

Application.ScreenUpdating = True
Set sh = Nothing 
Set My_rg = Nothing
Set F_rg = Nothing
Set Col = Nothing
ُErase arr
End Sub

**علي المصري** · مارس 2, 2021

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

تم نقل الكود الى الملف الأصلي حيث ان نتيجة الكود تكون في صفحة غير الموجود بها البيانات

قمت بالتعديل ... ولكن ارجو من حضرتك مراجعته

حيث انني اقتصرت الكود على جلب اسماء المدارس الثلاثة دون جلب باقي البيانات الخاصة بها

حيث انني اريد تحويل عدد الطلاب الى نسب مئوية وقمت بها باستخدام المعادلات

ولكن ظهرت مشكلة بسيطة ,, اذا كانت المدارس الثلاثة او اثنين متساويتان في المتوسط

يقوم الكود بتكرار اول مدرسة في ثلاث مرات ويترك الباقي..معذررة على الاطالة ,, مع الشكر الجزيل مقدما

Masry_collcetion.xlsm

**سليم حاصبيا** · مارس 2, 2021

هذا الكود يدرج التكرار (صفحة Salim من هذا الملف)
وضعته في صفحة مستقلة كي لا تتأثر الييانات في الصفحة الاساسية

فقط عليك تعديلة كما تريد

Sub First_Until_Third()
    Dim sh As Worksheet
    Dim My_rg As Range
    Dim F_rg As Range, xx As Long
    Dim ro As Long, i As Long
    Dim k As Byte, m As Byte
    Dim Cret1, Cret2
    Dim arr, Col As Object, Dic As Object
    Dim Lt, t%
    Dim Mn
 Application.ScreenUpdating = False

  Set sh = Sheets("Salim")
  Set My_rg = sh.Range("A1").CurrentRegion
  Set Col = CreateObject("System.Collections.ArrayList")
  Set Dic = CreateObject("Scripting.Dictionary")
  sh.Range("P9:Z20").ClearContents
  ro = My_rg.Rows.Count
  sh.Cells(2, 1).Resize(ro - 1, 12).Interior.ColorIndex = xlNone
  If sh.Range("P4") = "" Then sh.Range("P4") = "Grade 1"
  If sh.Range("P3") = "" Then sh.Range("P3") = "Arabic Language"
  Cret1 = sh.Range("P4"): Cret2 = sh.Range("P3")

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)

     arr = My_rg
       For i = 1 To UBound(arr)
        If IsNumeric(arr(i, 1)) Then
        Col.Add Val(arr(i, 1))
      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
If sh.FilterMode Then
 My_rg.AutoFilter
End If

m = 9: t = 0

Do Until t = Dic.Count + 1
        Set F_rg = My_rg.Find(Dic.keys()(t) _
        , lookat:=1)
         xx = F_rg.Row: Lt = xx
       Do
         sh.Cells(Lt, 1).Resize(, 12).Interior.ColorIndex = 6
         With sh.Cells(m, "P")
            .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
        t = t + 1
         If t = Dic.Count Then Exit Do
    Loop

Application.ScreenUpdating = True
 Set sh = Nothing
 Set My_rg = Nothing: Set F_rg = Nothing
 Set Col = Nothing: Set Dic = Nothing
 Erase arr
End Sub

Masry_NEW.xlsm

**علي المصري** · مارس 2, 2021

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

الملف الاصلي كما بالمرفق

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

قمت بتعديل الكود بما يتناسب مع هذا الوضع

ولكن عند تغيير الصف من الصف الاول الى اي صف اخر يعطي خطأ في الكود

ارجو من حضرتك حل المشكلة

وانا متأسف اني ارهقت حضرتك في الطلبات

وكما اود ان يكون الكود لجلب أسماء المدارس فقط دون اي بيانات اخرى

ارجو التعديل على المرفق في هذا التعليق

الكود يبحث في اول صف من البيانات قبل الفلترة

وبالتالي لا يجد الصف الدراسي المختار في الصف الاول من البيانات وبالتالي يعطي رسالة خطأ هذا ما فهمته

Masry_NEW_2_3_2021.xlsm

**سليم حاصبيا** · مارس 2, 2021

تم معالجة الأمر

اود ان يكون الكود لجلب أسماء المدارس فقط دون اي بيانات اخرى (يمكن التعديل كما تريد) من خلال الــ Loop

Sub First_Third_New()
    
    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
    Dim k As Byte, m As Byte
    Dim Cret1, Cret2
    Dim arr, Col As Object, Dic As Object
    Dim Lt, t%
    Dim Mn
 Application.ScreenUpdating = False

  Set sh = Sheets("Salim")
  Set sh1 = Sheets("Sheet1")
  Set My_rg = sh.Range("A1").CurrentRegion
  Set Col = CreateObject("System.Collections.ArrayList")
  Set Dic = CreateObject("Scripting.Dictionary")
  sh1.Range("C8:M13").ClearContents
  
  ro = My_rg.Rows.Count
  sh.Cells(2, 1).Resize(ro - 1, 12).Interior.ColorIndex = xlNone
  If sh1.Range("V8") = "" Then 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)

 If My_rg.Areas.Count = 1 Then
    arr = Application.Transpose(My_rg)
 Else
    arr = Application.Transpose(My_rg.Areas(2))
 End If
     
   For i = 1 To UBound(arr)
        If IsNumeric(arr(i)) Then
        Col.Add Val(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
If sh.FilterMode Then
 My_rg.AutoFilter
End If

m = 8: t = 0

Do Until t = Dic.Count + 1
        Set F_rg = My_rg.Find(Dic.keys()(t) _
        , lookat:=1)
         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
        t = t + 1
         If t = Dic.Count Then Exit Do
    Loop

Application.ScreenUpdating = True
 Set sh = Nothing
 Set My_rg = Nothing: Set F_rg = Nothing
 Set Col = Nothing: Set Dic = Nothing
 Erase arr
 
End Sub

Masry_Extra.xlsm

**علي المصري** · مارس 3, 2021

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

عند نسخ بيانات واضافتها إلى الصحفة
Salim
او نسخ الكود ووضعه في ملف جديد بنفس مسميات الاواراق يعطي الرسالة الموضحة بالصورة المرفق

image.png.2ed2900ee387383101cf7d5d0219b105.png

**سليم حاصبيا** · مارس 3, 2021

كيف لنا التعامل مع صورة بمعرفة الخطأ

الخطأ ربما كان هنا (اسم الصفحة)

**علي المصري** · مارس 3, 2021

معذرة

نسيت ارفق الملف

Masry_Extra3333333.xlsm

**سليم حاصبيا** · مارس 3, 2021

المشكلة كانت في عدم ترتيب الصفوف حسب الــ Grade

تم معالجة الأمر بتعديل الكود بحيث يعمل في كل الاحتمالات (ترتيب او عدم الترتيب)

Sub First_Third_New()
    
    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

  Set sh = Sheets("Salim")
  Set sh1 = Sheets("Sheet1")
  Set My_rg = sh.Range("A1").CurrentRegion
  Set Col = CreateObject("System.Collections.ArrayList")
  Set Dic = CreateObject("Scripting.Dictionary")
  sh1.Range("C8:M13").ClearContents
  
  ro = My_rg.Rows.Count
  sh.Cells(2, 1).Resize(ro - 1, 12).Interior.ColorIndex = xlNone
  If sh1.Range("V8") = "" Then 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
 
End Sub

Masry_Super.xlsm

**علي المصري** · مارس 3, 2021

شكرا جزيلا جزاكم الله خيرا

تسجيل الدخول

الحصول على بيانات المدارس الثلاثة الاولى من حيث المتوسط بشرط المادة والصف

الردود الموصى بها

علي المصري

سليم حاصبيا

علي المصري

سليم حاصبيا

علي المصري

سليم حاصبيا

سليم حاصبيا

علي المصري

سليم حاصبيا

علي المصري

سليم حاصبيا

علي المصري

سليم حاصبيا

علي المصري

سليم حاصبيا

علي المصري

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information