اذهب الي المحتوي
أوفيسنا

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

علي المصري

بواسطه علي المصري
في منتدى الاكسيل Excel

 مشاركة
إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

علي المصري

علي المصري

قام بنشر
قام بنشر

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

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

AliElmasry.xlsx

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

جرب هذا الماكرو  (هناك ورقة مخفية مساعدة 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

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك
علي المصري

علي المصري

قام بنشر
  • الكاتب
قام بنشر

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

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

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

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

sheet1

المساعدة 

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

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

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

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك
علي المصري

علي المصري

قام بنشر
  • الكاتب
قام بنشر

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

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

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

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

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

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

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

Masry_collcetion.xlsm

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

هذا الكود يدرج التكرار (صفحة 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

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك
علي المصري

علي المصري

قام بنشر
  • الكاتب
قام بنشر

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

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

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

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

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

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

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

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

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

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

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

Masry_NEW_2_3_2021.xlsm

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

اود ان يكون الكود لجلب أسماء المدارس فقط دون اي بيانات اخرى (يمكن التعديل كما تريد) من خلال الــ 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

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك
علي المصري

علي المصري

قام بنشر
  • الكاتب
قام بنشر

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

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

image.png.2ed2900ee387383101cf7d5d0219b105.png

رابط هذا التعليق
شارك
  • أفضل إجابة
سليم حاصبيا

سليم حاصبيا

قام بنشر
  • أفضل إجابة
قام بنشر

المشكلة كانت في عدم ترتيب الصفوف حسب الــ 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_pic.png

Masry_Super.xlsm

  • Like 2
  • Thanks 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept