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

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

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

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

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

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

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

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

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

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

صورة الفورم

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

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 CommandButton5_Click()
    Dim x As Date
    Dim y As Date
    Dim V As Long, Z As Long
    With Sheets("Data")
    If TextBox11.Text = "" Then Exit Sub
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        x = Format(TextBox11.Text, "dd/mm/yyyy")
        y = Format(TextBox12.Text, "dd/mm/yyyy")
        V = 0
        ListBox1.Clear
        For Z = 3 To LastRow
            If .Cells(Z, 3).Value >= x And .Cells(Z, 3).Value <= y Then
                ListBox1.AddItem
                ListBox1.List(V, 0) = Z
                ListBox1.List(V, 1) = .Cells(Z, 2).Value
                ListBox1.List(V, 2) = .Cells(Z, 3).Text
                ListBox1.List(V, 3) = .Cells(Z, 4).Value
                ListBox1.List(V, 4) = .Cells(Z, 5).Value
                ListBox1.List(V, 5) = .Cells(Z, 6).Value
                ListBox1.List(V, 6) = .Cells(Z, 7).Value
                ListBox1.List(V, 7) = .Cells(Z, 8).Value
                ListBox1.List(V, 8) = .Cells(Z, 9).Value
                V = V + 1
            End If
        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

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

وبالمرفقات نسخة اخرى معدلة
all in 1.rar
اعداد / ياسر العربي
تحياتي