ادخال - بحث واستدعاء في ليست بوكس- تعديل - تقرير بحث - حذف

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

اقدم لكم اليوم برنامج لادخال البيانات والبحث عنها باي شرط بحث حسب رغبتكم وعرض  النتائج داخل ليست بوكس

ويمكنكم التعديل على اي بيان وايضا يمكنكم عرض تقرير عن اي بحث  داخل شيت مستقل

وامكانية حذف بيان غير مرغوب به من شيت البيانات

طريقة العمل كالاتي

لادخال البيانات تكتب في اسفل الفورم داخل التكست بوكس ونتجاهل الخاصة بالصف  لانها ضمن اعدادات البحث ونضغط علي اضافة

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

للتعديل على صف يتم الضغط دبل كليك  علي الصف داخل الليست بوكس ليرحل الى التكست بوكس اسفل الفورم ومن ثم التعديل والضغط على تعديل

وللحذف يتم الضغط دبل كليك على الصف داخل الليست بوكس ليرحل الى التكست بوكس اسفل الفورم ومن ثم الضغط على حذف

لاستخراج نتيجة البحث  في شيت مستقل يتم الضغط علي تقرير بعد عمليه البحث ليتم ترحيل البيانات الى شيت التقرير ريبورت

صورة الفورم

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

 Private Sub CommandButton1_Click()  
   Dim LastRow As Integer  
   Dim ii As Integer  
   With Sheets("Data")  
     LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1  
     .Cells(LastRow, 2).Value = TextBox3.Text  
     .Cells(LastRow, 3).Value = TextBox4.Text  
     .Cells(LastRow, 4).Value = TextBox5.Text  
     .Cells(LastRow, 5).Value = TextBox6.Text  
     .Cells(LastRow, 6).Value = TextBox7.Text  
     .Cells(LastRow, 7).Value = TextBox8.Text  
     .Cells(LastRow, 8).Value = TextBox9.Text  
     .Cells(LastRow, 9).Value = TextBox10.Text  
   End With  
   For ii = 2 To 10  
     Me.Controls("TextBox" & ii).Value = ""  
   Next  
 End Sub  
 Private Sub CommandButton2_Click()  
   On Error Resume Next  
   ii = 2  
   For i = 0 To Me.ListBox1.ColumnCount  
     Me.ListBox1.List(ListBox1.ListIndex, i) = Me.Controls("TextBox" & ii).Value  
     ii = ii + 1  
   Next  
   With Sheets("Data")  
     .Cells(TextBox2, 2).Value = TextBox3.Text  
     .Cells(TextBox2, 3).Value = TextBox4.Text  
     .Cells(TextBox2, 4).Value = TextBox5.Text  
     .Cells(TextBox2, 5).Value = TextBox6.Text  
     .Cells(TextBox2, 6).Value = TextBox7.Text  
     .Cells(TextBox2, 7).Value = TextBox8.Text  
     .Cells(TextBox2, 8).Value = TextBox9.Text  
     .Cells(TextBox2, 9).Value = TextBox10.Text  
   End With  
 End Sub  
 Private Sub CommandButton3_Click()  
   Sheets("Data").Rows(TextBox2).Delete Shift:=xlUp  
   On Error Resume Next  
   ii = 2  
   For i = 0 To Me.ListBox1.ColumnCount  
     Me.ListBox1.List(ListBox1.ListIndex, i) = ""  
     Me.Controls("TextBox" & ii).Value = ""  
     ii = ii + 1  
   Next  
 End Sub  
 Private Sub CommandButton4_Click()  
   With Sheets("report")  
     .Range("b3:i200").ClearContents  
     Z = 3  
     For V = 0 To ListBox1.ListCount - 1  
       .Cells(Z, 2).Value = ListBox1.List(V, 1)  
       .Cells(Z, 3).Value = ListBox1.List(V, 2)  
       .Cells(Z, 4).Value = ListBox1.List(V, 3)  
       .Cells(Z, 5).Value = ListBox1.List(V, 4)  
       .Cells(Z, 6).Value = ListBox1.List(V, 5)  
       .Cells(Z, 7).Value = ListBox1.List(V, 6)  
       .Cells(Z, 8).Value = ListBox1.List(V, 7)  
       .Cells(Z, 9).Value = ListBox1.List(V, 8)  
       Z = Z + 1  
     Next  
   End With  
 End Sub  
 Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)  
   On Error Resume Next  
   ii = 2  
   For i = 0 To Me.ListBox1.ColumnCount  
     Me.Controls("TextBox" & ii).Value = Me.ListBox1.List(ListBox1.ListIndex, i)  
     ii = ii + 1  
   Next  
 End Sub  
 Private Sub TextBox1_Change()  
   On Error Resume Next  
   Dim ws As Worksheet  
   Dim V As Integer  
   Dim LastRow As Integer  
   Dim M As String  
   Dim Q, F  
   ListBox1.Clear  
   If TextBox1.Text = "" Then GoTo 1  
   M = TextBox1.Text  
   Set ws = Sheets("Data")  
   With ws  
     x = ComboBox1.ListIndex + 2  
     LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row  
     Set Q = Range(.Cells(2, x), .Cells(LastRow, x)).Find(M)  
     If Not Q Is Nothing Then  
       F = Q.Address  
       Do  
         If Application.WorksheetFunction.Search(M, Q, 0) = 1 Then  
           ListBox1.AddItem Q.Row  
           ListBox1.List(V, 1) = .Cells(Q.Row, 2).Value  
           ListBox1.List(V, 2) = .Cells(Q.Row, 3).Value  
           ListBox1.List(V, 3) = .Cells(Q.Row, 4).Text  
           ListBox1.List(V, 4) = .Cells(Q.Row, 5).Value  
           ListBox1.List(V, 5) = .Cells(Q.Row, 6).Value  
           ListBox1.List(V, 6) = .Cells(Q.Row, 7).Value  
           ListBox1.List(V, 7) = .Cells(Q.Row, 8).Value  
           ListBox1.List(V, 8) = .Cells(Q.Row, 9).Value  
           V = V + 1  
         End If  
         Set Q = Range(.Cells(2, x), .Cells(LastRow, x)).FindNext(Q)  
       Loop While Not Q Is Nothing And Q.Address <> F  
     End If  
   End With  
 1 End Sub  

لتحميل الملف اضغط هنا

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

تحياتي

شارك المقال

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