طلب مساعدة في إحصاء واستخلاص البيانات من قاعدة بيانات شيت1

[optimist99]

كل عام وأساتذتنا الكبار بخير

طلب مهم بالنسبة لي جدا في عملية استخلاص البيانات من قاعدة البيانات في الشيت1 باسم(Data)

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

أما الورقة الثانية وهي الأهم جدا.. أريد تنقبح الصفوف بحيث تكون بدون تكرار مع عملية دمج لمحتوى عمود(المدرسة) لأي صف مكرر(أي اسم مكرر)

والملف المرفق به التوضيح أكثر مع ذكر أمثلة لما أرغب الحصول عليه... ويفضل لو يكون باستخدام الأكواد.. ولكم الشكر مقدما

Data.xlsx

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

جرب هذا الكود

Option Explicit
Sub give_data()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim arr(), m%: m = 1
Dim k%, i%
Dim st$
Dim x%

Dim Source_sh As Worksheet: Set Source_sh = Sheets("Data")
Dim targ_sh As Worksheet: Set targ_sh = Sheets("Data1")
targ_sh.Range("e4").CurrentRegion.Offset(1).ClearContents
k = Source_sh.Range("d4").CurrentRegion.Rows.Count + 3
For i = 5 To k

 If Application.CountIf(Source_sh.Range("F5:F" & i), Source_sh.Range("F" & i)) = 1 Then
ReDim Preserve arr(1 To m): arr(m) = Source_sh.Range("F" & i)
m = m + 1
End If
Next
targ_sh.Range("E4").Resize(m - 1) = Application.Transpose(arr)

 For m = LBound(arr) To UBound(arr)
  For i = 5 To k
   If Source_sh.Range("f" & i) = arr(m) Then
    st = st & Source_sh.Range("G" & i) & Chr(10)
    End If
 Next
 st = Mid(st, 1, Len(st) - 1)
   targ_sh.Range("f" & m + 3) = st
   targ_sh.Range("f" & m + 3).WrapText = True
   st = ""
 Next
 x = Application.Max(targ_sh.Range("B:B")) + 3
 targ_sh.Range("d4:d" & x).Formula = _
 "=INDEX(Data!$E$5:$E$500,MATCH(E4,Data!$F$5:$F$500,0))"

  targ_sh.Range("G4:G" & x).Formula = _
 "=INDEX(Data!$H$5:$H$500,MATCH(E4,Data!$F$5:$F$500,0))"

  targ_sh.Range("H4:H" & x).Formula = _
 "=INDEX(Data!$I$5:$I$500,MATCH(E4,Data!$F$5:$F$500,0))"
 
  targ_sh.Range("I4:I" & x).Formula = _
 "=INDEX(Data!$J$5:$J$500,MATCH(E4,Data!$F$5:$F$500,0))"
 
 targ_sh.Range("d4:I" & x).Value = targ_sh.Range("d4:I" & x).Value
 Erase arr
 With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With

End Sub

بالنسبة للجدولين في الورقة الاولى تم عمل المعادلات للجدول الاول فقط (لضيق الوقت) يمكن عمل المعادلات للجدول الثاني بنفس الصيغة

الملف مرفق

 

 

Data _salim.xlsm

[احمد بدره]

دائمًا مبدع وأدعو الله أن يوفقك لما يحبه ويرضاه

كل عام أنت بخير

[optimist99]

رائع جدا جدا.. دائما مبدع

يعجز لساني عن الشكر. تماما نفس المطلوب بالضبط