التعديل على كود مختص بدالة if

[alliiia]

السلام عليكم ورحمة الله وبركاته ..أسعد الله أيامكم ..عندي هذا الملف ..وهذا  هو الكود

Sub if_loop ()
For Each cell In Range("H3:H10000")
If cell.Value = 1 Then
    cell.Offset(0, 4).Value = "تنبيه"
ElseIf cell.Value = 2 Then
    cell.Offset(0, 4).Value = "تعهد"
ElseIf cell.Value = 3 Then
    cell.Offset(0, 4).Value = "إنذار"
End If
Next cell
End Sub

لكن لأني حاطط معادلة ..في حال تكررت المخالفة من الطالب محمد1 سيكتب لي في عمود (تكرار المخالفة) رقم 2

فأنا أريد عندما تكون مخالفته رقم 1 يكتب لي تنبيه في عمود (حالة المخالفة) وتبقى ثابتة حتى لو تغير رقم 1 وما تتبدل كلمة تنبيه

لأنه خلاص المرة الأولى أنا نبهت الطالب ففي المرة الثاني يكتب لي تعهد ..فبمجرد ما يكرر الطالب المخالفة سيتغير رقم 1 القديم إلى رقم 2  

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

مخالفات.xlsm

[alliiia]

محاولة تمشي الحال ..لكنها غير دقيقة وجيدة

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
lr = Worksheets("المخالفات").Range("a" & Rows.Count).End(xlUp).Row
For r = 3 To lr
If Worksheets("المخالفات").Range("H" & r).Value = 1 And _
 Worksheets("المخالفات").Range("K" & r).Value = 1 Then
    Worksheets("المخالفات").Range("L" & r) = "تنبيه"
ElseIf Worksheets("المخالفات").Range("H" & r).Value = 2 And _
 Worksheets("المخالفات").Range("K" & r).Value = 1 Then
    Worksheets("المخالفات").Range("M" & r) = "تعهد"
      ElseIf Worksheets("المخالفات").Range("H" & r).Value = 3 And _
 Worksheets("المخالفات").Range("K" & r).Value = 1 Then
    Worksheets("المخالفات").Range("N" & r) = "إنذار"
        End If
Next r
End Sub

 

 

 

وقد جعلتها ثلاثة أعمدة 

عمود تنبيهات وعمود تعهدات وعمود إنذارات

[alliiia]

 محاولة ثالثة، لكن للأسف على ثلاثة أعمدة ليست على عمود 1

هل من حل يا أحبة؟

Sub info()
Dim i As Long
For i = 3 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    If ActiveSheet.Cells(i, 8 = 1 Then
        ActiveSheet.Range("L" & i) = "تنبيه"
   ElseIf ActiveSheet.Cells(i, 8 = 2 Then
        ActiveSheet.Range("M" & i) = "تعهد"
        End If
Next i
End Sub

مخالفات.xlsm