طلب مساعدة في ترقيم تسلسلي عن طريق الفورم

[زياد عبد الجليل]

السلام على جميع الاساتذة الافاضل ...عندي طلب يتمثل في الاتي

1- عندي ملف به فورم يتم من خلالها ترحيل بيانات من صفحة الى صفحة محددة اود عند الترحيل ان يقوم بعمل ترقيم تسلسلي في الخانة a اي كلما رحلت سطر ياخذ رقما تسلسليا و في حالة حذف سطر كذلك يعاد الترقيم تسلسليا و اليا

لمعرفة المطلوب بدقة ارجو الاطلاع على الملف المرفق و لكم مني جزيل الشكر و التقدير   

ترقيم تسلسلي عن طريق الفورم.rar

[زياد عبد الجليل]

للرفع

[زياد عبد الجليل]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Lr As Long: Lr = Cells(Rows.Count, "B").End(xlUp).Row
Dim myRange As Range
Dim cell As Range
Set myRange = Range("B21:B" & Lr)
    If Not Intersect(myRange, Target) Is Nothing Then
        For Each cell In myRange
        Range("a" & cell.Row) = cell.Row - 20
        Next cell
    End If
End Sub

لقد وضعت هذا الكود في حدث الورقة و يعمل بشكل جيد و لكن الاشكال هو ضرورة عدم كتابة اي شئ في العمود b من b33:b34  ارجو التعديل في هذا الكود و جعله يرقم من a21:a30 ونفس الشء بالنسبة للجدول ادناه من  a34:a40

[ياسر خليل أبو البراء]

صراحة لم أفهم المطلوب بشكل واضح ..عموماًُ إذا كنت تريد تغيير النطاق فقم بتغيير السطر التالي
 

Set myRange = Range("B21:B" & Lr)

استبدل حرف الـ B بحرف الـ A ، للتعامل مع العمود الأول وليس الثاني

[زياد عبد الجليل]

استاذ ياسر شكرا على مرورك الطيب ...انا اود عند ترحيل البيانات الى الجدول حسب الملف المرفق يقوم يترقيم المرحلين تسلسليا من 1 الى غاية اخر مرحل وليكن 5 كاخر مرحل ولكن عند حذف سطر مثلا و ليكن السطر الذي يحمل رقم 3 اود ان يعاد الترتيب تسلسليا من 1الى 4 وليس 1.2.4.5.

الكود الموضوع في حدث الورقة يعمل بشكل جيد ولكن عند الترحيل الى الجدول الثاني يجب عدم كتابة اي شئ في الخانات من b34:b40 واذا رحلنا الى هذه الخلايا هنا الترقيم سيتسلسل ابتداء من الخلية a21الى غاية اخر خلية بها قيمة في العمود b .

المطلوب ان امكن تعديل هذا الكود و حصره في التعامل مع النطاق من  a21:a30 و النطاق   a34:a40 او تقديم كود جديد يغنينا عن هذا الكود .

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Lr As Long: Lr = Cells(Rows.Count, "B").End(xlUp).Row
Dim myRange As Range
Dim cell As Range
Set myRange = Range("b21:b" & Lr)
    If Not Intersect(myRange, Target) Is Nothing Then
        For Each cell In myRange
        Range("a" & cell.Row) = cell.Row - 20
        Next cell
    End If
   Set myRange = Range("B34:B" & Lr)
    If Not Intersect(myRange, Target) Is Nothing Then
        For Each cell In myRange
        Range("a" & cell.Row) = cell.Row - 33
        Next cell
    End If
End Sub

وعند وضع الكود بهذا الشكل عن مسح خلايا بها قيم يرقم من الخلية a1 بهذا الشكل -1.-2.-3.-4.....ارجو وضع هذا الكود في الملف المرفق للاطلاع على المشكلة بدقة 

ولكم مني جزيل الشكر ...وانا على علم بان هناك من الاخوة الافاضل من لديه الحل سواء لهذا الكود او لكودجديد ان شاء الله...استودعكم الله الذي لا تضيع ودائعه ولكم مني جزيل الشكر و العرفان

[زياد عبد الجليل]

لقد وجدت حل الترقيم الالي التسلسلي في الكود التالي

With Feuil19
Last = wr.Range("b31").End(xlUp).Row + 1
.Cells(Last, 1) = Last - 20
End With

ولكن يبقى الاشكال عند الحذف 

 

على العموم اعلم ان الطلب شبه مستحيل و صعب اشكر كل من اطلع على الموضوع و حاول تقديم المساعدة ...واخص بالذكر الاستاذ ياسرالذي شرفني بمروره الطيب على الموضوع

بارك الله في الجميع