طلب تطوير كود

[ابومهندالخضري]

السلام عليكم

في الملف المرفق تم اضافة كود لاظهار رسالة خطأ عندما تكون قيمة الخلية B1 سالبه 

المطلوب هو تطوير الكود ليشمل كل الخلايا الملونة بالاصفر  اي من  B1  ولغاية D20 

وللامانة الكود اخذته من احد مشاركات الاستاذ m.hindawi احد عضاء منتدانا جزاه الله خيرا وقمت بتغيير بسيط فيه.

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

تطوير كود.rar

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

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

اذا وجدت اي خلية اصغر من صفر يقوم الكود بتحديدها لاصلاحها

Dim Rg As Range
Dim cel As Range, first_ad$, Other_Ad$

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
Range("B1:D20").Interior.ColorIndex = 6
If Not Intersect(Target, Range("B1:D20")) Is Nothing _
    And Target.Count = 1 Then
    Set Rg = Range("B1:D20").Find("-", lookat:=2)
      If Not Rg Is Nothing Then
       first_ad = Rg.Address: Other_Ad = first_ad
           Do
            Rg.Interior.ColorIndex = 50
            Set Rg = Range("B1:D20").FindNext(Rg)
            Other_Ad = Rg.Address
            If Other_Ad = first_ad Then Exit Do
          Loop
      End If
Else
    For Each cel In Range("B1:D20")
     If cel < 0 Then cel.Interior.ColorIndex = 50
    Next
End If
Application.EnableEvents = True
End Sub

الملف مرفق

 

 

MY_code.xlsm

[ابومهندالخضري]

الاخ سليم حاصبيا

كل الشكر للرد

ولكني اردت تطوير الكود المرفق ليشمل كل الخلايا 

بحيث عند وضع قيمه سالبه في اي منها يتوقف العمل ويظهر رسالة تنبيه

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

عندها يلزم هذا الكود

Dim cel As Range

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("B1:D20")) Is Nothing _
    And Target.Count = 1 Then
    Range("B1:D20").Interior.ColorIndex = 6
     For Each cel In Range("B1:D20")
        If cel < 0 Then cel.Interior.ColorIndex = 50
     Next
Else
     Application.EnableEvents = True: Exit Sub
End If
  If Not IsNumeric(Target) Or Target < O Then
    Target.Interior.ColorIndex = 50
    Target.Select
    MsgBox "خطأ" & Chr(10) & _
    "مسموح فقط بأعداد اكبر من صفر", 16, _
    vbMsgBoxRight
  End If

 Application.EnableEvents = True
End Sub

الملف من جديد

 

MY_NEW_CODE.xlsm

[أحمد يوسف]

أستاذ

ابومهندالخضري

أين الضغط على الإعجاب ؟!! 💙