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

[علي المصري]

الفكرة التي اريد تنفيذها
الجدول الملون بالاصفر يحتوي على درجات المدارس ( مدارس مختلفة ) حسب الصفوف والمادة  يوجد لكل صف اكثر من شعبة لها نفس الاسم
اريد كتابة صف واحد لكل مادة لكل مدرسة ويتم تجميع الاعداد حسب الصف والمدرسة ( وعملية الجمع تم تنفيذها ) ولكني اريد كتابة الصفوف والمدرسة دون تكرار كما بالجدول الملون بالاخضر

Book1.xlsx

[Ali Mohamed Ali]

السلام عليكم وذلك من خلال هذه المعادلة بداية من الخلية P2

=IFERROR(INDEX($A$2:$A$550,AGGREGATE(15,6,ROW($A$1:$A$302)/(MATCH($A$2:$A$550&$B$2:$B$550&$C$2:$C$550,$A$2:$A$550&$B$2:$B$550&$C$2:$C$550,0)=ROW($A$1:$A$302)),ROWS($2:2))),"")

Book2.xlsx

[سليم حاصبيا]

جرب هذا الكود

Option Explicit
Sub All_in_One()
Dim Ob As Object
Dim Lr, i
Dim Sd#, Se#, Sf#, Sg#, _
    Sh#, Si#, Sj#, Sk#
Dim kY
Dim Sal As Worksheet
Set Sal = Sheets("Salim")
Lr = Sal.Cells(Rows.Count, 1).End(3).Row
Sal.Range("P2").Resize(Lr, 12).ClearContents
Set Ob = CreateObject("Scripting.Dictionary")
With Sal
For i = 2 To Lr
  Sd = Sd + Val(.Cells(i, "D")): Se = Se + Val(.Cells(i, "E"))
  Sf = Sf + Val(.Cells(i, "F")): Sg = Sg + Val(.Cells(i, "G"))
  Sh = Sh + Val(.Cells(i, "H")): Si = Si + Val(.Cells(i, "I"))
  Sj = Sj + Val(.Cells(i, "J")): Sk = Sk + Val(.Cells(i, "K"))
   Ob(.Cells(i, 1) & "*" & .Cells(i, 2) & "*" & .Cells(i, 3)) = _
   Sd & "*" & Se & "*" & Sf & "*" & Sg & "*" _
   & Sh & "*" & Si & "*" & Sj & "*" & Sk
   
   If .Cells(i, 1) <> .Cells(i + 1, 1) Then
    Sd = 0: Se = 0: Sf = 0: Sg = 0: _
    Sh = 0: Si = 0: Sj = 0: Sk = 0
   End If
Next
 For i = 0 To Ob.Count - 1
 .Cells(2, "p").Offset(i).Resize(, 3) = Split(Ob.KEYS()(i), "*")
 .Cells(2, "S").Offset(i).Resize(, 8) = Split(Ob.iTEMS()(i), "*")
Next
.Cells(1, "P").CurrentRegion.Value = _
.Cells(1, "P").CurrentRegion.Value
End With

End Sub

الملف مرفق صفحة Salim

Ali_Mas.xlsm

[علي المصري]

شكرا جزيلا استاذ علي محمد علي

شكرا جزيلا استاذ سليم حاصبيا

حلين رائعين  

ولكن حاولت افهم تركيبية الدلة  AGGREGATE  ولكن لم استطع فهم طبيعة عمل هذه الدالة لاني او مرة اعرفها

اما الكود ساحاول التوصل لفهمه ولاطبقة على الملف الاصلي ان شاء الله

شكرا جزيلا

[saad abed]

استاذ سليم

اكوادك رائعة وفيها ابداعات

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

[سليم حاصبيا]

3 ساعات مضت, علي المصري said:

حل اخر في حال لم تكن المدارس مرتبة بالتسلسل (مع اضافة عدد المدارس والمتوسط الحسابي)

Option Explicit
Sub Colunms_with_dictionary()

 'Created By Salim Hasbaya On 14/2/2021
   Dim Sal As Worksheet
   Dim Ky, cl As Range, Dic As Object
   Dim st$, My_Average
   Dim k%, lR%, I%
   Dim Dic_count As Object
  Set Sal = Sheets("Salim")
  lR = Sal.Cells(Rows.Count, 1).End(3).Row
   Sal.Range("O2").Resize(lR, 13).ClearContents
    
    Set Dic = CreateObject("Scripting.Dictionary")
    Set Dic_count = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = vbTextCompare
    
    For Each cl In Sal.Range("A2:A" & lR).Cells
       st = cl.Value & "*" & cl.Offset(, 1).Value & "*" & _
            cl.Offset(, 2).Value
    '+++++++++++++++++++++++++++++++++
       Dic_count(st) = Dic_count(st) + 1
        
        If Not Dic.Exists(st) Then
            Dic.Add st, Val(cl.Offset(, 3)) & "*" & _
              Val(cl.Offset(, 4)) & "*" & _
              Val(cl.Offset(, 5)) & "*" & _
              Val(cl.Offset(, 6)) & "*" & _
              Val(cl.Offset(, 7)) & "*" & _
              Val(cl.Offset(, 8)) & "*" & _
              Val(cl.Offset(, 9)) & "*" & _
              Val(cl.Offset(, 10)) & "*"
         Else
            Dic(st) = _
                Split(Dic(st), "*")(0) + _
                  Val(cl.Offset(, 3)) & "*" & _
                Split(Dic(st), "*")(1) + _
                  Val(cl.Offset(, 4)) & "*" & _
                Split(Dic(st), "*")(2) + _
                  Val(cl.Offset(, 5)) & "*" & _
                Split(Dic(st), "*")(3) + _
                 Val(cl.Offset(, 6)) & "*" & _
                Split(Dic(st), "*")(4) + _
                  Val(cl.Offset(, 7)) & "*" & _
                Split(Dic(st), "*")(5) + _
                  Val(cl.Offset(, 8)) & "*" & _
                Split(Dic(st), "*")(6) + _
                  Val(cl.Offset(, 9)) & "*" & _
                Split(Dic(st), "*")(7) + _
                 Val(cl.Offset(, 10)) & "*"
            
        End If
    Next cl
  
   For Each Ky In Dic_count.keys
    Sal.Cells(k + 2, 15) = Dic_count(Ky)
    k = k + 1
   Next
     k = 0
   For Each Ky In Dic.keys
        Sal.Cells(k + 2, 16).Resize(, 3) = Split(Ky, "*")
      For I = 19 To 26
       Sal.Cells(k + 2, I) = Split(Dic(Ky), "*")(I - 19)
      Next I
    
     My_Average = Evaluate(Join(Split(Dic(Ky), "*"), "+") & 0)
     My_Average = Round(My_Average / 8, 2)
     Sal.Cells(k + 2, I) = My_Average
    k = k + 1
    Next Ky
End Sub

شكرا جزيلا

الملف من جديد

Ali_Mas_Special.xlsm

[علي المصري]

شكرا جزيلا على الاهتمام

انا جربت الدالة الخاصة بالاستاذ علي محمد علي 
والكود الخاص بالاستاذ سليم حاصبيا
لكن عندي البياناتت الخاصة بالمدراس تصل الى الصف رقم 15000 
وفي بعض الحالات تكون اكثر

مما ادى إلى بطء شديد جدا في الحسابات وادى الى توقف برنامج الاكسيل

سوف اقوم بتجربة الحل الجديد 

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

مع خالص تحياتي لكم 

 

[سليم حاصبيا]

هذه لم أفهمها 
       ارجو تعديد الكود ليشمل فقط الاعمدة الثلاثة الاولى وهي الصف والمادة والمدرسة سواء بالجدول الاساسي

[علي المصري]

السلام عليكم استاذ سليم

اعني ان الاعمدة التي بها الروز

A,B.B+,C,C+,D,E,F,average 
انا كاتب بها معادلة لحساب القيم فيها

فلا اريد ادراجها من االكود

هذا ما اقصده

وانما المشكلة في عملية بطء الحسابات الان

شكرا جزيلا

انا قمت بكتابة الكود التالي يعتمد على3 ازرار

زر لحساب المدراس وفلترتها 

زر لتشغيل الحساب التلقائي للخلايا

زر لايقف التشغيل التلقائي للحسابات

هو يعمل جيد واختصر جزء بسيط من وقت الحسابات ايضا 

ولكنه مع البيانات الكبيرة يتاخر ايضا في الحسابات

 

Sub AliElbasry2021()
'
' Macro2 Macro
'

'

Application.ScreenUpdating = False

If Sheet3.Range("P2").Value <> "" Then
Sheet3.Range("P2:R10001").ClearContents
End If
Application.Calculation = xlManual


Dim i As Integer
For i = 2 To 10001
If Sheet3.Range("A" & i).Value <> "" Then

Sheet3.Range("P" & i).Value = Sheet3.Range("A" & i).Value
Sheet3.Range("Q" & i).Value = Sheet3.Range("B" & i).Value
Sheet3.Range("R" & i).Value = Sheet3.Range("C" & i).Value

Else
GoTo 1

End If
 Next i
1    Range("P2:P10001").Select
     Range("P2:R10001").Select
    Application.CutCopyMode = False
    ActiveSheet.Range("$P$2:$R$10001").RemoveDuplicates Columns:=Array(1, 2, 3), _
        Header:=xlNo
    Columns("P:R").EntireColumn.AutoFit
 Application.Calculation = xlAutomatic
   
    Range("A2").Select
    Application.ScreenUpdating = True

End Sub

Sub calcMe()
Application.Calculation = xlAutomatic
End Sub

Sub Nocalc()
Application.Calculation = xlManual
End Sub

 

[سليم حاصبيا]

3 ساعات مضت, علي المصري said:

السلام عليكم استاذ سليم

اعني ان الاعمدة التي بها الروز

A,B.B+,C,C+,D,E,F,average 
انا كاتب بها معادلة لحساب القيم فيها

فلا اريد ادراجها من االكود

هذا ما اقصده

 

 

وانما المشكلة في عملية بطء الحسابات الان

شكرا جزيلا

 

انا قمت بكتابة الكود التالي يعتمد على3 ازرار

زر لحساب المدراس وفلترتها 

زر لتشغيل الحساب التلقائي للخلايا

زر لايقف التشغيل التلقائي للحسابات

هو يعمل جيد واختصر جزء بسيط من وقت الحسابات ايضا 

ولكنه مع البيانات الكبيرة يتاخر ايضا في الحسابات

 

 

لا افهم ما الحاجة الى الحلقات التكرارية في هذه الحالة

يكفي هذا الكود

بعد تنفيذ الكود يتم استبدال المعادلات بقيمها  الحقيقية من خلال الأمر (value=.value.)
للتقليل من حجم الملف لانه يحنوي على 10 أعمدة (حيث يوجد معادلات)  في كل واحد حوالي 10000 معادلة 
( و بذلك لا يتم ارهاق البرنامج بحساب أكثر من  100 الف معادلة مع كل ضربة على الكيبورد او نقرة من الماوس)

Sub Get_by_formula()
Dim Last_ro%, New_row
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With Sheets("Sheet3")
Last_ro = .Cells(Rows.Count, 1).End(3).Row
 .Range("O2").Resize(Last_ro - 1, 13).Clear
 .Range("P2").Resize(Last_ro - 1, 3).Value = _
 .Range("A2").Resize(Last_ro - 1, 3).Value
 .Range("P2").Resize(Last_ro - 1, 3).RemoveDuplicates _
  Columns:=Array(1, 2, 3)
 New_row = .Cells(Rows.Count, "P").End(3).Row
   With .Range("O2").Resize(New_row - 1, 13)
     .Borders.LineStyle = 1
     .Font.Bold = True
     .Font.Size = 12
     .InsertIndent 1
     .Cells(1, 5).Resize(New_row - 1, 8).Formula = _
        "=SUMPRODUCT(--($P2&$Q2&$R2=$A$2:$A$10000&$B$2:$B$10000&$C$2:$C$10000),D$2:D$10000)"
     .Cells(1, 1).Resize(New_row - 1).Formula = _
        "=SUMPRODUCT(--($P2&$Q2&$R2=$A$2:$A$10000&$B$2:$B$10000&$C$2:$C$10000))"
     .Cells(1, 13).Resize(New_row - 1).Formula = _
        "=ROUND(AVERAGE(S2:Z2),2)"
     .Value = .Value
    End With
End With
    With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    End With

End Sub

الصفحة  Sheet3 من هذا الملف

 

Ali_1xlsm.xlsm

[علي المصري]

5 ساعات مضت, سليم حاصبيا said:

.Cells(1, 1).Resize(New_row - 1).Formula = _ "=SUMPRODUCT(--($P2&$Q2&$R2=$A$2:$A$10000&$B$2:$B$10000&$C$2:$C$10000))" .Cells(1, 13).Resize(New_row - 1).Formula = _ "=ROUND(AVERAGE(S2:Z2),2)"

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

بالنسبة الى حساب المتوسط

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

اذا امكن تعديل هذه الجزئية لاني لم استطع تعديلها

شاكرا لك اهتمامك وسرعة ردك

 

[سليم حاصبيا]

اولاً يجب ان أعرف من اين اتيت بهذه الأرقام

[علي المصري]

يتم حسابها في السيستم لكل شعبة

فهي نسبة جاهزة 

 

اضفت هذا قبل نهاية الكود

واعطت النتيجة صحيحة

 

With Sheets("Sheet3")

   With .Range("O2").Resize(New_row - 1, 13)
    .Cells(1, 13).Resize(New_row - 1, 1).Formula = _
        "=SUMPRODUCT(--($P2&$Q2&$R2=$A$2:$A$10000&$B$2:$B$10000&$C$2:$C$10000),(L$2:L$10000)/$O2)"
     .Value = .Value
   End With
End With

 

تم تعديل فبراير 16, 2021 بواسطه علي المصري

[سليم حاصبيا]

حسناً فعلت

لكن اريد ان استفسر بالنسبة لسرعة تنفيذ الكود(هل ما زال بطيئاً؟؟)

لمعرفة الوقت الذي استغرقه الماكرو  (اجزاء من 1000 من الثواني)  اضف الى الكود حسب ما في هذه الصورة

 

 

[علي المصري]

هذا الوقت مع عدد الصفوف 1800