التصفية من خلال الاسم الرباعي

[ماجدجلال]

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

اخواني الاعزاء , هل يمكن في الاكسيل  عمل بحث بواسطة تصفية الاسماء الرباعية , بحث عند كتابة الاسم المراد البحث عنة في الخانة المخصصة له تختفي كل الاسماء الاخري و يظهر فقط الاسم المراد البحث عنة ...

في الملف المرفق صفحتين , الاول قبل البحث ( هي للتوضيح فقط ) بحيث عند كتابة مثلا اسم العائلة ( خليل ) اختفت كل الاسماء و بقيت الاسماء التي عائلتها خليل , و يتم تطبيق الفكرة علي بقية اجزاء الاسم , فمثلا عند كتابة محمد  في خانة الاسم الاول وكتابة خليل في خانة اسم العائلة تبقي فقط الاسماء التي بها فقط محمد خليل وهاكذا 

وشكرا لكم 

التصفية من خلال البحث.xlsx

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

جرب هذا الملف

 

My_filter.xlsm

[ماجدجلال]

بارك الله فيك استاذ سليم 

لقد حاولت التغير في الكود بحيث يتم دمج الصفحتين في صفحة واحدة , يعني يكون عندنا جدول واحد فقط بحيث عندما تكون مربعات البحث الاربعه فارغة تظهر جميع البيانات , ارجو المساعدة ..

حاولت الاعتماد علي نفسي حتي لا اثقل عليك و لكن دون جدوي 

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

تم التعديل

 

My_filter_new.xlsm

[ماجدجلال]

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

الف الف شكرا 

[ماجدجلال]

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

استاذ سليم 

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

Union(Range("D5"), Range("E5"), Range("F5")).ClearContents

لانة عند البحث عن اسم وليكن مثلا محمد علي احمد هلال , فمن الطبيعي انك تبدا اولا بادخال اسم محمد فيتم عرض كل الاسماء التي اولاها محمد فقط , ثم يتم الانتقال الي الخلية المجاورة لادخال اسم الاب و هو علي فيتم عرض الاسماء التي هي فقط محمد علي , وعند الانتقال الي الخلية المجاورة لادخال اسم الجد وهو احمد فيتم عرض فقط الاسماء التي هي محمد علي احمد و اخيرا الانتقال الي الخلية المجاورة وادخال اسم العائلة وهو هلال فيتم فقط عرض الاسم الوحيد وهو محمد علي احمد هلال ,,,,

الملاحظة الثانية : عندما قمت بحذف الصفحة الاولي وهي ( قبل البحث ) ظهر الخطاء التالي 

Set RGs = Source.Range("B8").CurrentRegion

فتاكدت ان الاسماء تعتمد كليا علي الصفحة الاولي و لا نستطيع حذفها , وان الاضافة او التعديل يكون فقط في الصفحة الاولي , 

الملاحظة الثالثة : و قد عجزت ايضا عن حلها او اكتشافة سببها وهي ظهور اكثر من خلية نشطة في نفس الصفحة ارجو النظر الي الصورة , الخلية الاساسية هي E5

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

معليش و الله حاولت الاعتماد علي نفسي للتعديل حتي لا ازعجكم و لكن ضاع اليوم باكلمة دون جدوي ,,,

ارجو المساعدة و لكم جزيل الشكر و الامتنان 

تم تعديل أكتوبر 4, 2019 بواسطه ماجدجلال
اضافة صورة لتوضيح المشكلة

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

جرب هذا الماكرو

Option Explicit

Private Sub Worksheet_Activate()
FIL_data_val
End Sub
'++++++++++++++++++++++++++++++++++++++++
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("C5:F5")) Is Nothing And Target.Count = 1 Then
    new_filter
End If
Application.EnableEvents = True
End Sub
'++++++++++++++++++++++++++++++++++++++
Sub new_filter()
Dim i As Byte, k As Byte
Dim LX%, RO%, x
Dim arr()
Dim st1, st2
Dim Rg As Range: Set Rg = Targt.Range("C5:F5")
Dim Frg As Range: Set Frg = Source.Range("b8").CurrentRegion
RO = Frg.Rows.Count
k = 4: x = 0
On Error Resume Next
If Source.AutoFilterMode Then
 Source.ShowAllData: Frg.AutoFilter
End If
On Error GoTo 0
Targt.Range("b8").CurrentRegion.ClearContents
 For i = 1 To k
    If Rg.Cells(i) <> "" Then
        x = x + 1
        ReDim Preserve arr(1 To x):
        arr(x) = Rg.Cells(i) & "*" & i + 1
    End If
  Next i
  On Error Resume Next
 LX = LBound(arr)
 If LX = 0 Then
    Frg.Copy Targt.Range("B8")
    GoTo End_Me
 End If
 On Error GoTo 0
  For i = LBound(arr) To UBound(arr)
    st1 = Val(Split(arr(i), "*")(1))
    st2 = Split(arr(i), "*")(0)
    Frg.AutoFilter Field:=st1, Criteria1:=st2
  Next i
  Frg.SpecialCells(2, 23).Copy Targt.Range("B8")
 
 On Error Resume Next
End_Me:
  If Source.AutoFilterMode Then
    Source.ShowAllData: Frg.AutoFilter
 End If
  
End Sub

الملف مرفق

 

My_filter_new_1.xlsm

[ماجدجلال]

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

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

من خلال مساعدتك الكثير لي و من خلال ما تعلمته منك استطعت اجراء تعديلات بيسطة في البرنانج السابق و عجزت من حل مشكلة كبيرة ارجو منك كرما التدخل , الملف المرفق به شرح اكثر وضوحا 

ارجو من معاليكم المساعدة و الف الف شكرا لك 

جزاك الله عني كل الخير 1520.xlsm

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

تم التعديل على الماكروات كما يلزم (فقط اضغط على الزر بحث)

Option Explicit

Sub cop()
Dim R1%, R2%
R1 = Range("b8").CurrentRegion.Rows.Count
R2 = Range("A10000").CurrentRegion.Rows.Count
If R1 > R2 Then
 Range("A10000").CurrentRegion.ClearContents
 Range("B8").CurrentRegion.Copy Range("A10000")
 End If
End Sub
Private Sub Worksheet_Activate()
FIL_data_val
End Sub
'++++++++++++++++++++++++++++++++++++++
Sub new_filter()
cop
Dim i As Byte, k As Byte
Dim LX%, RO%, x
Dim arr()
Dim st1, st2
Dim Rg As Range: Set Rg = Targt.Range("C5:F5")
Dim Frg As Range: Set Frg = Range("A10000").CurrentRegion
RO = Frg.Rows.Count
k = 4: x = 0
On Error Resume Next
If Frg.AutoFilterMode Then
 Frg.ShowAllData: Frg.AutoFilter
End If
On Error GoTo 0
Targt.Range("b8").CurrentRegion.ClearContents
 For i = 1 To k
    If Rg.Cells(i) <> "" Then
        x = x + 1
        ReDim Preserve arr(1 To x):
        arr(x) = Rg.Cells(i) & "*" & i + 1
    End If
  Next i
  On Error Resume Next
 LX = LBound(arr)
 If LX = 0 Then
    Frg.Copy Targt.Range("B8")

  Frg.ShowAllData: Frg.AutoFilter
    GoTo End_Me
 End If
 On Error GoTo 0
  For i = LBound(arr) To UBound(arr)
    st1 = Val(Split(arr(i), "*")(1))
    st2 = Split(arr(i), "*")(0)
    Frg.AutoFilter Field:=st1, Criteria1:=st2
  Next i
  Frg.SpecialCells(2, 23).Copy Targt.Range("B8")
 
 On Error Resume Next
End_Me:
 
   If Frg.AutoFilterMode Then
  
    Frg.ShowAllData: Frg.AutoFilter
 End If
  
End Sub
'++++++++++++++++++++++++++++++++++++

Sub FIL_data_val()
Dim RGs As Range
Dim Coll As Object
Dim Rs%, Rt%, i%, k%

Set RGs = Range("a10000").CurrentRegion
Rs = RGs.Rows.Count
Set Coll = CreateObject("System.Collections.Arraylist")
 For i = 2 To 5
 With RGs.Columns(i).Offset(1).Resize(Rs - 1)

     For k = 1 To Rs - 1
      
       If Not Coll.contains(.Cells(k).Value) Then
         Coll.Add .Cells(k).Value
        End If
    Next k
 End With
 Coll.Sort
   With Targt.Cells(5, "c").Offset(, i - 2).Validation
        .Delete
        .Add 3, Formula1:=Join(Coll.toArray, ",")
        
    End With
 Coll.Clear
Next i
End Sub

 

15_20.xlsm

[ماجدجلال]

تمام 

يادكتور ,,, ممتاز 

الله ينور عليك , هذا المطلوب و اكثر , واكثر منكذا روحك العالية واخلاقك الكريمة اذ تحملتني و علمتني , الف الف مليون شكرا