محتاج اضافة بحث

[kawas]

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

لكم جزيل شكر اذا امكن ارغب باضافة فورم بحث للصفحتين مبنى البحث على الاسم ورقم المعاملة 

شاكر لكم تعاونكم 

كشف المعاملات المؤرشفة.xlsx

[كمال على طارق]

وعليكم السلام -من فضلك قم بتصميم ما تريد من الفورم وسيتم المساعدة من قبل الساتذة ان شاء الله .. فالمنتدى تعليمى من المقام الأول !!!

[محمد هشام.]

 

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

تفضل اخي ضع الكود التالي في Module

Function arr(a, b)
   maxtab1 = UBound(a)
   Dim tmp(): ReDim tmp(1 To UBound(a) + UBound(b), 1 To UBound(a, 2))
   For i = LBound(a) To UBound(a)
     For c = 1 To UBound(a, 2): tmp(i, c) = a(i, c): Next
   Next i
   For i = 1 To UBound(b)
     For c = 1 To UBound(b, 2): tmp(maxtab1 + i, c) = b(i, c): Next
   Next i
   arr = tmp
End Function

وفي داخل اليوزرفورم 

Dim rng(), Cnt, Width, OneRng, ColVisu
'09/06/2024     by:MOHAMEED HICHAM    www.officena.net     "منتدى الاكسيل" '
Private Sub UserForm_Initialize()
  Dim Cpt, F
  Cpt = [Data]: F = [Data1]: rng = arr(Cpt, F)  'Merge table data
  For i = LBound(rng) To UBound(rng): rng(i, 2) = Format(rng(i, 2), "dd/mm/yyyy"): Next i
  OneRng = "Data"
  Width = Array(100, 80, 80, 160, 80, 60)
  ColVisu = Array(6, 5, 4, 3, 2, 1): Cnt = UBound(ColVisu) + 1
  For c = 1 To Cnt
  tmp = Range(OneRng).Offset(-1).Item(1, c)
  Me("Label" & c).Caption = tmp: Me("Labtxt" & c).Caption = tmp
  Next
 txtClear
 Me.ListBox1.ColumnCount = Cnt
 Me.ListBox1.ColumnWidths = Join(Width, ";")
 Dim result(): n = 0
  For i = 1 To UBound(rng)
      n = n + 1: ReDim Preserve result(1 To Cnt, 1 To n)
      c = 0
      For Each k In ColVisu
        c = c + 1: result(c, n) = rng(i, k)
      Next k
  Next i
  If n > 0 Then
  Me.ListBox1.Column = result: Counter = ListBox1.ListCount
  Else
  Me.ListBox1.Clear
  End If
End Sub
'*****************
Sub filterdata()
Dim result(): n = 0
Dim Cpt1 As String, Cpt2 As String
    For i = 1 To UBound(rng)
    'الاسم
      If TextBox1.Value = "" Then Cpt1 = rng(i, 3) Else Cpt1 = "*" & TextBox1.Value & "*"
    'رقم المعاملة
      If TextBox2.Value = "" Then Cpt2 = rng(i, 6) Else Cpt2 = "*" & TextBox2.Value & "*"
      If LCase(rng(i, 3)) Like LCase(Cpt1) And LCase(rng(i, 6)) Like LCase(Cpt2) Then
      n = n + 1: ReDim Preserve result(1 To Cnt, 1 To n)
      c = 0
      For Each r In ColVisu
        c = c + 1: result(c, n) = rng(i, r)
            Next r
          End If
      Next i
If n > 0 Then
  Me.ListBox1.Column = result
  Counter = ListBox1.ListCount
  Else
  Me.ListBox1.Clear
  End If
  txtClear
End Sub
'***********************
Private Sub TextBox1_Change()
Call filterdata
End Sub
Private Sub TextBox2_Change()
Call filterdata
End Sub
Private Sub ListBox1_Click()
For i = 1 To Cnt
 Me("txt" & i) = Me.ListBox1.Column(i - 1)
Next i
End Sub
'*********************
Private Sub transfert_Click()
  Set WS = Sheets("Sheet1")
  WS.Cells.ClearContents
  n = ListBox1.ListCount: result = Me.ListBox1.List
  WS.[A2].Resize(n, 6) = Application.Index(result, _
  Evaluate("Row(1:" & n & ")"), ColVisu)
  c = 0
  For c = 1 To Cnt
  WS.Cells(1, c) = Range(OneRng).Offset(-1).Item(1, c)
  Next
   Me.TextBox1 = "": Me.TextBox2 = ""
  MsgBox "تم ترحيل البيانات بنجاح", Exclamation, "admin"
End Sub
'*************************
Sub txtClear()
    For k = 1 To Cnt
      Me("txt" & k) = ""
    Next k
End Sub

 

كشف المعاملات المؤرشفة.xlsb

[kawas]

شكرا لك اخي العزيز