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

[ابوذر]

اساتذة الكرام اريد حل .

من الجدول 2 يبحث بالقسم و مادة التدريس في الجدول 1 و يجلب الاستاذ المدرس للقسم للمادة 

وشكرا 

المصنف العمل.xlsx

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

اولاً  ازالة دمج الخلايا من  الجدول الثاني مطلوبة لحسن عمل الكود (تمت المعالجة)

ثانياً تم تغيير اسم الصفحة الى SALIM   لسهولة التعامل مع الكود من حيث النسخ واللصق (استعمل دائما أسماء الصفحات باللغة الأجنبية)

ثالثاً  تم تكبير الجدول الاساسي ليستوعب حوالي 100 صف

الكود

Option Explicit
Sub TEST()
    Dim DIC As Object
    Dim S As Worksheet
    Dim cel As Range
    Dim my_rg As Range

Set DIC = CreateObject("Scripting.Dictionary")
Set S = Sheets("salim")

For Each cel In Range("h7:Ac100")
 If cel <> "" Then
  DIC(cel.Value) = ""
  End If
 Next
 Set my_rg = S.Range("aF7").CurrentRegion
    If my_rg.Rows.Count <> 1 Then
     my_rg.Offset(1).Resize(my_rg.Rows.Count - 1, 6).ClearContents
    End If
 S.Range("aF8").Resize(DIC.Count - 1) = _
 Application.Transpose(DIC.keys)
    
    S.Range("aG8").FormulaArray = _
    "=IFERROR(INDEX($B$7:$B$100,MATCH($AF8&AG$7,$H$7:$H$100&$C$7:$C$100,0)),"""")"
    S.Range("aG8").AutoFill Destination:=S.Range("AG8:AK8")
    S.Range("AG8:AK8").AutoFill Destination:=S.Range("AG8:AK" & DIC.Count + 6)
    S.Range("AG8:AK" & DIC.Count + 6).Value = _
    S.Range("AG8:AK" & DIC.Count + 6).Value
 DIC.RemoveAll: Set DIC = Nothing
 Set my_rg = Nothing: Set S = Nothing
 
End Sub

الملف مرفق

 

Prof_Madda.xlsm

[ابوذر]

شكرا مسبقا 

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

في الملف تتم عملية الجلب بالعمود الاول للنتيجة لا ينتقل للعمود الثاني 

شكرا 

Prof_Madda1.xlsm

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

تم تصحيح الماكرو ليتعامل مع جميع الأعمدة

Option Explicit
Sub SALIM_S_Macro()
Dim DIC As Object
Dim S As Worksheet
Dim my_rg, cel, F_rg As Range
Dim First_ad$, Act_ad$, ro%, col%

Set DIC = CreateObject("Scripting.Dictionary")
Set S = Sheets("salim")
For Each cel In Range("h7:Ac100")
 If cel <> vbNullString Then
  DIC(cel.Value) = vbNullString
  End If
 Next

 Set my_rg = S.Range("aF7").CurrentRegion
    If my_rg.Rows.Count <> 1 Then
     my_rg.Offset(1).Resize(my_rg.Rows.Count - 1, 6).ClearContents
    End If
 S.Range("aF8").Resize(DIC.Count) = _
 Application.Transpose(DIC.keys)
  '+++++++++++++++++++++++++++++++++++++++++++++++
  For Each cel In S.Range("aF8").Resize(DIC.Count)
       Set F_rg = S.Range("h7:Ac100").Find(cel, lookat:=1)
      If Not F_rg Is Nothing Then
           First_ad = F_rg.Address: Act_ad = First_ad
           Do
              ro = S.Range(Act_ad).Row
                 Select Case Cells(ro, 3)
                    Case "عربية": col = 1
                    Case "رياضيات": col = 2
                    Case "فرنسية": col = 3
                    Case "علوم ط": col = 4
                    Case "فيزياء": col = 5
                  End Select
              cel.Offset(, col) = S.Cells(ro, 2)
              Set F_rg = S.Range("h7:Ac100").FindNext(F_rg)
              Act_ad = F_rg.Address
              If Act_ad = First_ad Then Exit Do
            Loop
      End If
   Next
 DIC.RemoveAll: Set DIC = Nothing
 Set my_rg = Nothing: Set S = Nothing
 Set F_rg = Nothing
End Sub

 

Prof_Madda2.xlsm

[ابوذر]

شكرا استادنا الغالي سليم

لكن اريد تعديل بسيط 

1- الجدول الاول ممكن يكون به عدد متغير من الاساتدة و التخصصات

2- في الجدول الثاني يمكن في ان يزيد عدد الاقسام او ينقص يتراوح بين 10اقسام حى 46 قسم كحد اقصى

كما لبد من ان تكون الاقسام مرتبة من 1م1 1م2 1م3 الخ لذلك عند تشكيل الماكرو فانه يغير الترتيب

جزاك الله كل خير و عافية

شكرا

 

Prof_Madda3.xlsm

Prof_Madda4.xlsm

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

بواسطة هذا الكود يمكن ترتيب الاقسام في الجدول الثاني

القوائم المنسدلة في الجدول الثاني ليس لها حاجة حيث ان الاقسام تظهر مرتبة

بالنسبة لعدد الاقسام يمكن زيادتها الى قدر ما تشاء (ضمن النطاق   H7:AC100 ) والماكرو يأخذها كلها دون تكرار وبالترتيب

 

Option Explicit
Sub New_code()
                Rem Created By Salim Hasbaya On 27/1/2020
    Dim oBJ As Object
    Dim S As Worksheet
    Dim cel As Range, my_rg As Range, F_rg As Range
    Dim i%, ro%, col%
    Dim First_ad$, Act_ad$
 
    Set oBJ = CreateObject("System.Collections.arraylist")
    Set S = Sheets("salim")
'==============================
For Each cel In S.Range("H7:AC100")
    If Not oBJ.contains(cel.Value) _
    And cel <> "" Then oBJ.Add cel.Value
Next
oBJ.Sort
 
 Set my_rg = S.Range("AF7").CurrentRegion
    If my_rg.Rows.Count <> 1 Then
     my_rg.Offset(1).Resize(my_rg.Rows.Count - 1, 6).ClearContents
    End If
 
 Cells(8, "AF").Resize(oBJ.Count).Value = _
 Application.Transpose(oBJ.Toarray)
    
    For Each cel In S.Range("AF8").Resize(oBJ.Count)
       Set F_rg = S.Range("H7:AC100").Find(cel, lookat:=1)
      If Not F_rg Is Nothing Then
           First_ad = F_rg.Address: Act_ad = First_ad
           Do
              ro = S.Range(Act_ad).Row
                 Select Case Cells(ro, 3)
                    Case "عربية": col = 1
                    Case "رياضيات": col = 2
                    Case "فرنسية": col = 3
                    Case "علوم ط": col = 4
                    Case "فيزياء": col = 5
                  End Select
              cel.Offset(, col) = S.Cells(ro, 2)
              Set F_rg = S.Range("H7:AC100").FindNext(F_rg)
              Act_ad = F_rg.Address
              If Act_ad = First_ad Then Exit Do
            Loop
      End If
   Next

 Set my_rg = Nothing: Set S = Nothing
 Set F_rg = Nothing: Set oBJ = Nothing
End Sub

الملف من جديد

 

 

 

Prof_Madda_New.xlsm

[ابوذر]

مشكور الاستاذ سليم

عمل رائع

عندي مواد كنت قد نسيتها و لاستطع التعديل على المكرة.

اريد طلب صغير هل يمكن عمل هذا بمعادلة

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

 

Prof_Madda_New1.xlsm

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

تم التعديل على الكود

لا يمكن عمل هذا الشيء بالمعادلات

Option Explicit
Sub New_code_Modifier()
                Rem Created By Salim Hasbaya On 27/1/2020
                Application.ScreenUpdating = False
    Dim oBJ As Object
    Dim S As Worksheet
    Dim cel As Range, my_rg As Range, F_rg As Range
    Dim i%, ro%, col%
    Dim First_ad$, Act_ad$
 
    Set oBJ = CreateObject("System.Collections.arraylist")
    Set S = Sheets("salim")
'==============================
For Each cel In S.Range("H7:AC100")
    If Not oBJ.contains(cel.Value) _
    And cel <> "" Then oBJ.Add cel.Value
Next
oBJ.Sort
 
 Set my_rg = S.Range("AF7").CurrentRegion
    If my_rg.Rows.Count <> 1 Then
     my_rg.Offset(1).Resize(my_rg.Rows.Count - 1, 12).ClearContents
    End If
 
 Cells(8, "AF").Resize(oBJ.Count).Value = _
  Application.Transpose(oBJ.Toarray)
    
    For Each cel In S.Range("AF8").Resize(oBJ.Count)
       Set F_rg = S.Range("H7:AC100").Find(cel, lookat:=1)
      If Not F_rg Is Nothing Then
           First_ad = F_rg.Address: Act_ad = First_ad
           Do
              ro = S.Range(Act_ad).Row
              col = Application.Match(S.Cells(ro, 3), S.Range("AG7:AQ7"), 0)
              cel.Offset(, col) = S.Cells(ro, 2)
              Set F_rg = S.Range("H7:AC100").FindNext(F_rg)
              Act_ad = F_rg.Address
              If Act_ad = First_ad Then Exit Do
            Loop
      End If
   Next

 Set my_rg = Nothing: Set S = Nothing
 Set F_rg = Nothing: Set oBJ = Nothing
  Application.ScreenUpdating = True
End Sub

 

 

Prof_Madda_Final.xlsm