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

**علي المصري** · فبراير 14, 2021

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

Book1.xlsx

**Ali Mohamed Ali** · فبراير 14, 2021

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

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

جرب هذا الكود

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

**علي المصري** · فبراير 14, 2021

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

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

حلين رائعين

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

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

شكرا جزيلا

**saad abed** · فبراير 14, 2021

استاذ سليم

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

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

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

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

**علي المصري** · فبراير 15, 2021

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

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

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

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

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

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

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

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

**علي المصري** · فبراير 15, 2021

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

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

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

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

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

**علي المصري** · فبراير 15, 2021

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

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

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

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

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

**علي المصري** · فبراير 16, 2021

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

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

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

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

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 بواسطه علي المصري

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

حسناً فعلت

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

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

**علي المصري** · فبراير 16, 2021

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

تسجيل الدخول

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

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

علي المصري

Ali Mohamed Ali

سليم حاصبيا

علي المصري

saad abed

سليم حاصبيا

علي المصري

سليم حاصبيا

علي المصري

سليم حاصبيا

علي المصري

سليم حاصبيا

علي المصري

سليم حاصبيا

علي المصري

Join the conversation

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

تصفح الموقع

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

Support

Important Information