بحث في الفورم

[ابو .. عبدالرحمن]

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

اخواني الكرام اريد مساعدة في تعديل هذا الامر 

Private Sub CommandButton1_Click()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
  For Each f In ws.Range("a2:a1000")
  If f = TextBox1.Text Then
  ws.Select
  f.Select
  Exit For
  End If
  Next f
  Next ws
  ActiveCell.Value = TextBox1.Value
  ActiveCell.Offset(0, 1).Value = TextBox2.Value
    ActiveCell.Offset(0, 2).Value = TextBox3.Value
     ActiveCell.Offset(0, 3).Value = TextBox4.Value
      ActiveCell.Offset(0, 4).Value = TextBox5.Value
       ActiveCell.Offset(0, 5).Value = TextBox6.Value
       MsgBox "تم تعديل البيانات بنجاح"
  
  TextBox1.Value = ""
     TextBox2.Value = ""
   TextBox3.Value = ""
   TextBox4.Value = ""
   TextBox5.Value = ""
   TextBox6.Value = ""
   TextBox8.Value = ""  
End Sub

Private Sub TextBox8_Change()

'    TextBox1.Value = ""
'    TextBox2.Value = ""
'    TextBox3.Value = ""
'    TextBox4.Value = ""
'    TextBox5.Value = ""
'    TextBox6.Value = ""
'    TextBox7.Value = ""
'
If TextBox8.Value = "" Then ListBox1.Clear: Exit Sub
Dim x As Worksheet

         ListBox1.Clear
    k = 0
For Each x In ThisWorkbook.Worksheets
        ss = x.Cells(Rows.Count, 1).End(xlUp).Row
        For Each c In x.Range("a2:a" & ss)
            b = InStr(c, TextBox8)
            If b > 0 Then
                ListBox1.AddItem
                ListBox1.List(k, 0) = x.Cells(c.Row, 1).Value
                ListBox1.List(k, 1) = x.Cells(c.Row, 2).Value
                ListBox1.List(k, 2) = x.Cells(c.Row, 3).Value
                ListBox1.List(k, 3) = x.Cells(c.Row, 4).Value
                ListBox1.List(k, 4) = x.Cells(c.Row, 5).Value
                ListBox1.List(k, 5) = x.Cells(c.Row, 6).Value
'                ListBox1.List(k, 6) = x.Cells(c.Row, 7).Value
                k = k + 1
            End If
        Next c

Next x
End Sub

اريد يبحث في شيت واحد فقط 

ويكون البحث في نطاق الخلية a1 الى الخلية k1

بحيث يتم استخراج كلمة البحث من الخلية h5 h6 h7 ............. الى اخر الجدول

ولكم جزيل الشكر

 

[ابو .. عبدالرحمن]

بحث في الفورم.xlsb

 

هذا ملف ارفقته ووضحت فيه المطلوب باختصار

اتمنى اجد من يساعدنى ولكم جزيل الشكر

[محمد هشام.]

تفضل جرب 

Option Compare Text
Dim f, Rng, wsData()
Private Sub UserForm_Initialize()
  Set f = Sheets("التقرير")
  Set Rng = f.Range("A3:j" & f.[A65000].End(xlUp).Row)
  wsData = Rng.Value
  Me.ListBox1.List = wsData
  Me.ListBox1.ColumnCount = 10
  Me.ListBox1.ColumnWidths = "120;65;65;80;80;65;80;65;80;65"
  Me.combobox1.List = Application.Transpose(Rng.Offset(-1).Resize(1))
  Me.combobox1.ListIndex = 0
  Me.LabelColFiltre.Caption = "بحث ب :" & Me.combobox1
End Sub
Private Sub combobox1_click()
  Me.LabelColFiltre.Caption = "بحث ب: " & Me.combobox1
End Sub
Private Sub TextBox1_Change()
  Réf_Colmun = Me.combobox1.ListIndex + 1
  clé = "*" & Me.TextBox1 & "*": n = 0
  Dim A()
  For i = 1 To UBound(wsData)
    If wsData(i, Réf_Colmun) Like clé Then
        n = n + 1: ReDim Preserve A(1 To UBound(wsData, 2), 1 To n)
        For k = 1 To UBound(wsData, 2): A(k, n) = wsData(i, k): Next k
     End If
  Next i
  If n > 0 Then Me.ListBox1.Column = A Else Me.ListBox1.Clear
End Sub

 

 

بحث في الفورم.xlsb

تم تعديل يوليو 10, 2023 بواسطه محمد هشام.

[ابو .. عبدالرحمن]

مشكور يارك الله فيك

رغم اني كنت اتوقع اني لم احتاج الى تغيير الفورم

 

ولكن اشكرك على الاستجابة والمساعدة وتحياتي لك

[ابو وحيد]

استاذ محمد 

ممكن شرح للكود لاني احتاج اعدل عليه ليتوافق مع الملف الي عندي