تعديل على كود للبحث

[طارق_طلعت]

السادة الأفاضل

بعد التحية

ارجو المساعدة فى تعديل الكود المرفق

حيث ان الكود يقوم بالبحث عن قيمة معينة فى العمود B و عند ايجادها يقوم بتعديل الأشارة و تلوين الرقم باللون الأحمر و يستمر فى البحث عن نفس القيمة فى العمود حتى يقوم بتنفيذ المطلوب على جميع القيم المطابقة للبحث

و حيث اننى لا اعلم عدد الخلايا المطابقة فقمت بعمل حلقة تكرارية لتكرار البحث لأيجاد جميع القيم المطابقة

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

و المطلوب انة عندما تكون نتيجة البحث (لا يوجد) فبقوم الكود بالخروج من الحلقة التكرارية و انهاء العمل

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

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

كود بحث.xlsm

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

جرب هذا الماكرو

Option Explicit
Sub salim_code()

  Dim s As Worksheet
  Dim La%, I%, Ro1, Ro2
  Dim F_rg As Range, Source_rg As Range
  Dim My_number

Set s = Sheets("Sheet1")
La = s.Cells(Rows.Count, 2).End(3).Row
Set Source_rg = s.Range("B4:B" & La)
Source_rg.Font.ColorIndex = vbBlack
My_number = Abs(s.Range("F3"))
  
  For I = 5 To La
   If IsNumeric(Cells(I, 2)) Then _
    s.Cells(I, 2) = Abs(s.Cells(I, 2))
  Next
For I = 4 To La
   If s.Cells(I, 2) = My_number Then
    s.Cells(I, 2) = -s.Cells(I, 2)
    s.Cells(I, 2).Font.ColorIndex = 3
   End If
Next I
 
   End Sub

الملف مرفق

Saerch_Please.xlsm

[طارق_طلعت]

شكرا جزيلا استاذ سليم

الكود يعمل تمام

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

و اسف على تعبك معايا 

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

تم التعديل على الكود ليعمل على طريقة (Find)

Option Explicit
Sub Salim_Code_With_Find_Methode()

  Dim S As Worksheet
  Dim La%, first_address
  Dim find_range As Range, Source_rg As Range
  Dim My_cel As Range, Opt_rg As Range 'Optional range
  
Set S = Sheets("Sheet1")
La = S.Cells(Rows.Count, 2).End(3).Row
Set Source_rg = S.Range("B5:B" & La)
Source_rg.Font.ColorIndex = vbBlack

 For Each My_cel In Source_rg
  My_cel = Abs(My_cel)
 Next
 
 With S.Range("B4:B" & La)
    Set find_range = .Find([f3], after:=Range("B" & La), lookat:=1)
  If Not find_range Is Nothing Then
    first_address = find_range.Address
    
    Do
      If Opt_rg Is Nothing Then
         Set Opt_rg = Range("B" & find_range.Row)
      Else
         Set Opt_rg = Union(Opt_rg, Range("B" & find_range.Row))
      End If
      Set find_range = .FindNext(find_range)
      If first_address = find_range.Address Then Exit Do
    Loop
  
  End If
End With
    
    If Not Opt_rg Is Nothing Then
     Opt_rg.Value = -Opt_rg.Value
     Opt_rg.Font.ColorIndex = 3
    Else
     MsgBox "Your Value: " & [f3] & Chr(10) & " Is'nt Found"
    End If
End Sub

الملف مرفق

 

Saerch_Please_Find.xlsm

[طارق_طلعت]

.شكرا جزيلا على المساعده 

[abouelhassan]

بارك الله فيك استاذنا سليم حاصبيا

والله بارك الله فى حضرتك