تنشيط البحث برقم الفاتورة بداية من A2 وجعل الفروم يعمل ايضا عند قفل الـ protect sheet

[هشام جمال الدين]

تنشيط البحث برقم الفاتورة بداية من A2 وجعل الفروم يعمل ايضا عند قفل الـ protect sheet 

وكل عام وانتم بخير

ليست بوكس2.xlsm

[سليم حاصبيا]

1-تسمية اوراق العمل دائماً باللغة الاجنبية وأرفض من الآن وصاعداً اي ملف اسماء صفحاته باللغة العربية لما يسبب هذا الشيء من اضطراب في الكود اضافة الى صعوبة نسخة ولصقة لظهور احرف غريبة فية (عند البعض طبعاً)
  مع احترامي الشديد للغتنا العربية (لغة القرآن الكريم) لكنها لا تصلح لوضع اكواد الـــ VBA (نسبة الأحطاء 70% حسب الدّراسات)

2-  للبحث عن اي فاتورة اكتب رقمها ثم اضغط Enter  ( يتم تحديد ما تبحث عنه باللون الأصفر في الشبت)

          أو  ( قم بتجديدها من الــ List Box )

3- لحذف  اي فاتورة اكتب رقمها ثم اضغط الزر حذف
         أو  ( قم بتجديدها من الــ List Box ) ثم اضغط الزر حذف

الاكواد المطلوبة

Option Explicit
Private sh As Worksheet
Private Ro%, Col%, i%
Private Arr_text(), Arr_Num()
Private F As Range, itm, K%
'++++++++++++++++++++++++++++++++++

Sub Debut()
Set sh = Sheets("Main")
Ro = sh.Cells(Rows.Count, 1).End(3).Row
Col = 7
Arr_text = Array("Fat", "Dat", "Cahier", "Prod", _
   "Qty", "Price", "Total")
Arr_Num = Array(1, 2, 3, 4, 5, 6, 7)
sh.Cells(1, 1).Resize(Ro, 7).Interior.ColorIndex = xlNone
End Sub
'+++++++++++++++++++++++++++++++++++++++

Private Sub Cmd_del_Click()
 Debut
If Me.ListBox1.ListCount = 0 Or Me.Fnd = "" Then Exit Sub
 Set F = sh.Range("A1:A" & Ro).Find(Me.Fnd, Lookat:=1)
 If F Is Nothing Then Exit Sub
  K = F.Row
  If K <> 1 Then
  sh.Cells(K, 1).Resize(, 7).Delete
  UserForm_Initialize
   For Each itm In Arr_text
    Me.Controls(itm) = ""
   Next
   Fnd = ""
  End If
End Sub
'+++++++++++++++++++++++++++++++++++++++

Private Sub Fnd_AfterUpdate()
Debut

If Fnd = "" Then Exit Sub
 For Each itm In Arr_text
  Me.Controls(itm) = ""
 Next
 Set F = sh.Range("A1:A" & Ro).Find(Me.Fnd, Lookat:=1)
 If F Is Nothing Then
  MsgBox "This Item: " & """" & Me.Fnd & """" & Chr(10) & _
  "Not Exists In Column (A)"
    Exit Sub
   End If
  K = F.Row
 For i = 0 To 6
   Me.Controls(Arr_text(i)).Text = _
   sh.Cells(K, Arr_Num(i))
 Next
 sh.Cells(K, 1).Offset(1).Select
 sh.Cells(K, 1).Resize(, 7).Interior.ColorIndex = 6
 
End Sub
'+++++++++++++++++++++++++++++++

Private Sub ListBox1_Click()
Debut
 If ListBox1.ListCount = 0 Then Exit Sub
 If ListBox1.ListIndex = -1 Then Exit Sub
 
 Fnd = ListBox1.List(ListBox1.ListIndex, 0)
 Fnd_AfterUpdate
End Sub

'++++++++++++++++++++++++++++++++++++++++++
Private Sub UserForm_Initialize()
Debut
Me.ListBox1.RowSource = _
 sh.Range("A2").Resize(Ro, Col).Address
End Sub

الملف مرفق

My_ListBox.xlsm

[هشام جمال الدين]

اخى الفاضل جزاكم الله خيرا ..

لكنى اريد عرض النتائج فقط فى الليست بوكس 

هل يمكن 

[سليم حاصبيا]

نتائج ماذا وبحث ماذا ????

كل الذي عندك فاتورة واحدة  (غير مكررة) في كل سطر من الورقة 

و عندما تبجث عنها تراها امامك في التكس بوكسات ويتلون الصف في الشيت
(لا افهم هنا ما  قيمة التكس بوكسات اذا كنت نريد النتائج في اللــ  ListBox )

 

[هشام جمال الدين]

يا سيدى الفاضل اريد عند كتابة رقم فى التكست بوكس 

تظهر النتائج فى الليست بوكس 

[سليم حاصبيا]

وهذا ما يحصل اكتب الرقم واضغط انتر وتظهر النتائج في  التكست بوكس وليس في الليست بوكس

[هشام جمال الدين]

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

فانا اريد عند ظهور النتائج اعمل سيليكت على نتيجة معينة وحذفها 

وجزاكم الله خيرا

My_ListBox (2).xlsm

[سليم حاصبيا]

تم التعذيل على الماكروات

Option Explicit
Private sh As Worksheet
Private Ro%, Col%, i%
Private Arr_text(), Arr_Num()
Private F As Range, itm, K%
'++++++++++++++++++++++++++++++++++
Private Sub Fnd_change()
Debut
Dim R1%, R2%
Me.ListBox1.RowSource = ""
If Fnd = "" Then Exit Sub
 For Each itm In Arr_text
  Me.Controls(itm) = ""
 Next
 Set F = sh.Range("A1:A" & Ro).Find(Me.Fnd & "*", Lookat:=2)
  If Not F Is Nothing Then
   R1 = F.Row: R2 = R1
  Do
   With Me.ListBox1
   .AddItem
   For i = 0 To .ColumnCount - 1
    .List(.ListCount - 1, i) = sh.Cells(R2, 1).Offset(, i)
   Next
   Set F = sh.Range("A1:A" & Ro).FindNext(F)
   R2 = F.Row
   If R2 = R1 Then Exit Do
   End With
  Loop
 End If
End Sub
'+++++++++++++++++++++++++++++++

Private Sub ListBox1_Click()
Debut
Dim t%
 If ListBox1.ListCount = 0 Then Exit Sub
 If ListBox1.ListIndex = -1 Then Exit Sub

  t = Me.ListBox1.ListIndex
  Set F = sh.Range("A1:A" & Ro).Find(Me.ListBox1.List(t, 0), Lookat:=1)
 If F Is Nothing Then Exit Sub
  K = F.Row
  If K <> 1 Then
 For i = 0 To 6
   Me.Controls(Arr_text(i)).Text = _
   sh.Cells(K, Arr_Num(i))
 Next
 End If

End Sub
'+++++++++++++++++++++++++++++++++++++
Sub Debut()
Set sh = Sheets("Main")
Ro = sh.Cells(Rows.Count, 1).End(3).Row
Col = 7
Arr_text = Array("Fat", "Dat", "Cahier", "Prod", _
   "Qty", "Price", "Total")
Arr_Num = Array(1, 2, 3, 4, 5, 6, 7)
sh.Cells(1, 1).Resize(Ro, 7).Interior.ColorIndex = xlNone
End Sub
'+++++++++++++++++++++++++++++++++++++++

Private Sub Cmd_del_Click()
 Debut
 Dim t%, st
If Me.ListBox1.ListCount = 0 Or Me.Fnd = "" Then Exit Sub
 t = Me.ListBox1.ListIndex
 st = Me.ListBox1.List(t, 0)
  Set F = sh.Range("A1:A" & Ro).Find(st, Lookat:=1)
 If F Is Nothing Then Exit Sub
  K = F.Row
  If K <> 1 Then
  sh.Cells(K, 1).Resize(, 7).Delete
  Me.ListBox1.RemoveItem (t)
  ListBox1.ListIndex = -1
  For i = 0 To 6
   Me.Controls(Arr_text(i)) = ""
  Next
  MsgBox "the Item " & """" & st & """" & Chr(10) & _
   "with address " & """" & sh.Cells(K, 1).Resize(, 7).Address(0, 0) _
   & """" & " Is Deleted", 64

  Fnd = ""
  End If

End Sub
'+++++++++++++++++++++++++++++++++++++++

Private Sub UserForm_Initialize()
Debut
Me.ListBox1.RowSource = _
 sh.Range("A2").Resize(Ro, Col).Address
End Sub

الملف من جديد

My_ListBox_1.xlsm

[هشام جمال الدين]

جزاكم الله خيرا اخى الفاضل سليم حاصبيا كل الشكر والتقدير