كود مميز جاهز_كود بحث مع فلترة البيانات

[جلال الجمال_ابو أدهم]

تحياتى و ايام مباركه

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

و يمكن تعديل على الملف باعادة تسمية رؤوس الاعمدة بالصف A3 و تسمية المقابل Option Button Form

مرفق الملف

search_gadham_clear.rar

و لا تنسونا من صالح الدعا ء

تحياتى

تم تعديل نوفمبر 23, 2016 بواسطه جلال الجمال_ابو أدهم

[جلال الجمال_ابو أدهم]

مرفق الكود المستخدم لل زر

Sub SearchBox()
Dim myButton As OptionButton
Dim SearchString As String
Dim ButtonName As String
Dim sht As Worksheet
Dim myField As Long
Dim DataRange As Range
Dim mySearch As Variant
  Set sht = ActiveSheet
  On Error Resume Next
    sht.ShowAllData
  On Error GoTo 0
  Set DataRange = sht.Range("A3:f1000")
  mySearch = sht.Shapes("UserSearch").TextFrame.Characters.Text
  If IsNumeric(mySearch) = True Then
    SearchString = "=" & mySearch
  Else
    SearchString = "=*" & mySearch & "*"
  End If
  For Each myButton In sht.OptionButtons
    If myButton.Value = 1 Then
      ButtonName = myButton.Text
      Exit For
    End If
  Next myButton
  On Error GoTo HeadingNotFound
    myField = Application.WorksheetFunction.Match(ButtonName, DataRange.Rows(1), 0)
  On Error GoTo 0
  DataRange.AutoFilter _
    Field:=myField, _
    Criteria1:=SearchString, _
    Operator:=xlAnd
  sht.Shapes("UserSearch").TextFrame.Characters.Text = ""
Exit Sub
HeadingNotFound:
  MsgBox "The column heading [" & ButtonName & "] was not found in cells " & DataRange.Rows(1).Address & ". " & _
    vbNewLine & "Please check for possible typos.", vbCritical, "Header Name Not Found!"
  
End Sub

و لاسترجاع البيانات المفلترة
 

Sub ClearFilter_Click()
  On Error Resume Next
    ActiveSheet.ShowAllData
  On Error GoTo 0
End Sub

 

[عبد الله السعيد]

اكثر من رائع استاذنا   ، لو تكرمت بصورة عاجلة ومحتاجه ضروري  اريد مايلي ان سمحت لي

01- ان يقبل مئــات الصفوف
02- ان يكون البحث في صفحة والداتا في صفحة اخرى
03- ان يكون في خانة البحث بالاسم  مربعين  احدهم بداية الاسم فقط  ، والثاني كما وضعته

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

 

تم تعديل نوفمبر 25, 2016 بواسطه عبد الله السعيد