التعديل على كود الترقيم التلقائي

[أبو قاسم]

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
On Error Resume Next
Dim R As Integer
If Not Intersect(Target.Cells(1, 1), Union(Range("B3:B4000"), Range("o3:o5000"))) Is Nothing Then
    R = Target.Row
    If Cells(R, "B").Value <> "" Then
        Cells(R, "A").Value = R + 44
        'محتاج التعديل على الكود حيث يبداء الترقم من 44 ويتوقف عن الترقيم عند الرقم 100
    Else
    End If
          End If
               Application.ScreenUpdating = True
On Error GoTo 0
End Sub

محتاج يتوقف الترقيم عند العدد 100 فقط ولايتجاوزة

[أبو عبد النور]

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

ارفق مثال على ذلك يكون احسن.

[أبو قاسم]

19 دقائق مضت, أبو عبد النور said:

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

ارفق مثال على ذلك يكون احسن.

Book2.rar

[ابراهيم الحداد]

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

استبدل الكود السابق بهذا الكود

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
On Error Resume Next
Dim R As Integer
 LR = Range("A" & Rows.Count).End(xlUp).Row + 1
If Not Intersect(Target.Cells(1, 1), Union(Range("B3:B4000"), Range("o3:o5000"))) Is Nothing Then
    R = Target.Row
    If Cells(R, "B").Value <> "" Then
       If Cells(LR - 1, "A").Value <= 99 Then
        Cells(R, "A").Value = R + 44
        'محتاج التعديل على الكود حيث يبداء الترقم من 44 ويتوقف عن الترقيم عند الرقم 100
    Else
    End If
          End If
            End If
               Application.ScreenUpdating = True
On Error GoTo 0
End Sub

 

[أبو قاسم]

شكرا لك وجزاك الله عنا الف خير