بحث متقدم مع امكانية اضافة شيت بالاسم المحدد من الليست او الذهاب الى شيت الاسم

بسم الله الرحمن الرحيم

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

وعرض النتائج في كمبوبوكس والليست بوكس

وايضا تم اضافة امكانية تحديد الاسم من الليست بوكس 

وعمل شيت بنفس الاسم المحدد داخل اللسيت

كما يمكنك ايضا من الذهاب الى شيت  الاسم المحدد داخل الليست بوكس

الكود المستخدم داخل الملف

كود البحث

 Private Sub ComboBox1_Change()  
   Dim a()  
   Dim b, c, d, e  
   Dim Ws As Worksheet: Set Ws = Sheets("Sheet1")  
   e = Ws.Range("a40000").End(xlUp).Row  
   a = Ws.Range("A2:a" & e).Value  
   With Me.ComboBox1  
     .List = a  
     .ListRows = 20  
     .MatchEntry = fmMatchEntryNone  
     .TextAlign = fmTextAlignCenter  
   End With  
   Set b = CreateObject("Scripting.Dictionary")  
   d = "*" & UCase(Me.ComboBox1) & "*"  
   For Each c In a  
     If UCase(c) Like d Then b(c) = ""  
   Next c  
   Me.ComboBox1.List = b.keys  
   Dim l As MSForms.ComboBox: Set l = Me.ComboBox1  
   Dim i As Long: i = 0  
   While i < l.ListCount  
     If "" = Trim$(l.List(i, 0)) Then: l.RemoveItem (i): Else i = 1 + i  
   Wend  
   ListBox1.AddItem  
   ListBox1.List = ComboBox1.List  
 End Sub  

كود اضافة شيت بالاسم المختار من الليست بوكس

 Private Sub CommandButton1_Click()  
   Dim Ws As Worksheet  
   Application.ScreenUpdating = False  
   Application.EnableEvents = False  
   On Error Resume Next  
   Set Ws = Worksheets(CStr(ListBox1.Text))  
   On Error GoTo 0  
   If Ws Is Nothing Then  
     Sheets.Add After:=Sheets(Sheets.Count)  
     ActiveSheet.Name = CStr(ListBox1.Text)  
     Sheet1.Activate  
     Set Ws = Nothing  
   End If  
   Application.EnableEvents = True  
   Application.ScreenUpdating = True  
 End Sub  

كود الذهاب الى شيت الاسم المختار

 Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)  
   Dim Ws As Worksheet  
   On Error Resume Next  
   Set Ws = Worksheets(CStr(ListBox1.Value))  
   Ws.Activate  
   Set Ws = Nothing  
 End Sub  

لتحمل البرنامج اضغط هنا


اعداد / ياسر العربي

شارك المقال

شاركه على فيسبوكشاركه على جوجل+