محتاج إضافة بحث إلى فورم الملف المرفق

[أبو قاسم]

السلام عليكم مشكورين على جهودكم الطيبة محتاج إضافة على الملف المرفق إضافة بحث وإظهار النتائج

يوزر فورم١.xlsb

تم تعديل يونيو 2, 2024 بواسطه أبو قاسم
ارفاق

[محمد هشام.]

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

Option Compare Text
Dim depart, Cnt, comment, f, ColSearch(), J
Public Property Get WS() As Worksheet: Set WS = ActiveSheet
End Property

Private Sub UserForm_Initialize()
Dim arr()
  comment = " تحديد ورقة العمل"
  Me.Label1.Width = 900
  depart = Me.Label1.Left
  Message = " برنامج المخازن يرحب بكم . صل على محمد"
  Me.Label1.Caption = "**********" & Message & "**********" & Message & "************"
  Cnt = Len(Me.Label1.Caption): Me.ComboBox1 = comment
  ColSearch = Array(3, 2, 1)
  J = UBound(ColSearch) + 1
  For i = 1 To 3: Me("head" & i).Visible = False: Next i
  k = 1
  For Each sh In ActiveWorkbook.Sheets
   If sh.Cells(3, 3) <> Empty Then
     ReDim Preserve arr(1 To k)
     arr(k) = sh.Name
     k = k + 1
    End If
  Next sh
  Me.ComboBox1.List = arr
  Me.ComboBox1.ListIndex = 0
  Count.Caption = ListBox1.ListCount
  Me.ComboBox1 = comment
End Sub
'***************************************

Private Sub Textbox1_Change()
  r = "*" & Me.Textbox1 & "*"
  Dim Cpt(): n = 0
  For i = 1 To UBound(f)
    If f(i, 1) Like r Then  ' فلترة بالاسم عمود (1)
      n = n + 1: ReDim Preserve Cpt(1 To J, 1 To n)
      c = 0
      For Each k In ColSearch
        c = c + 1: Cpt(c, n) = f(i, k)
      Next k
    End If
  Next i
  If n > 0 Then Me.ListBox1.Column = Cpt Else Me.ListBox1.Clear
  Count.Caption = ListBox1.ListCount
End Sub

'*******************************

Private Sub ComboBox1_Change()
On Error Resume Next
Sheets(CStr(ComboBox1)).Activate
f = WS.Range("A3:C" & WS.[a65000].End(xlUp).Row).Value
If Me.ComboBox1 <> comment And WS.Cells(3, 3) <> "" Then
For i = 1 To 3: Me("Hard" & i).Visible = True: Next i
 Set d = CreateObject("Scripting.Dictionary")
  For i = LBound(f) To UBound(f)
     If f(i, 1) <> "" Then d(i) = Array(f(i, 3), f(i, 2), f(i, 1))
  Next i
  n = d.Count
  If n > 0 Then
    Dim Cpt: Cpt = Application.Transpose(d.items)
    ReDim Preserve Cpt(1 To 3, 1 To n + 1)
    Me.ListBox1.List = Application.Transpose(Cpt)
    Me.ListBox1.RemoveItem n
  For i = 1 To 3: Me("Hard" & i) = WS.Cells(2, i): Next i
Count.Caption = ListBox1.ListCount
     End If
  End If
End Sub

 

 

 

يوزر فورم3.xlsb

تم تعديل يونيو 3, 2024 بواسطه محمد هشام.

[أبو قاسم]

جزاك الله خير  المطلوب وزيادة شكرا لك 

[محمد هشام.]

ولك بالمثل اخي @أبو قاسم يسعدنا اننا استطعنا مساعدتك