ترقيم تلقائي لا يتأثر بحذف أي صف من الصفوف و متابعة الترقيم

[algammal]

السادة خبراء أوفيسنا الكرام

السلام عليكم ورحمة الله وبركاته (جميعا)

أرجو مساعدتي كما تعودت منكم دائما فيما يلي:

عمل ترقيم تلقائي كما هو موضح في الصفحات المرفقة  بحيث لا يتأثر بحذف أي صف من الصفوف و متابعة الترقيم مهما زاد عدد الصفحات أو قل
ولكم جميعا خالص شكري وتقديري مقدما

وجعلكم الله دوما عونا لكل من أراد العون.

مطلوب ترقيم تلقائى لا يتأثر بحذف الصفوف.xlsx

[محمد هشام.]

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

صراحة أخي @algammal التعامل مع الملف باستخدام المعادلات لتنفيذ طلبك غير عملي خصوصا أنك ترغب في إمكانية الترقيم التلقائي عند حذف أو إضافة صفوف جديدة أو حتى  جدول جديد  ما يزيد من التعقيد هو وجود العديد من الخلايا المدمجة  والصفوف الفارغة على عمود الترقيم  أعتقد أن الحل الأنسب هنا هو استخدام الأكواد  

مجرد إقتراح ربما يناسبك 

الكود التالي يعمل بشكل ديناميكي ويتعرف تلقائيا على الجداول بناءا على كلمات مفتاحية تحدد بداية الجدول ونهايته قمت بتحديدها نظرا لشكل تصميمك للملف حيث يقوم الكود بالبحث عن كلمة "الاسم" في عمود B للتعرف على بداية الجدول  ومن ثم يبحث عن كلمة "المختص" في نفس العمود لتحديد نهاية الجدول  وبمجرد تحديد نطاق الجدول سيقوم  الكود بإعادة الترقيم على الجداول المتواجدة في الملف  داخل هذا النطاق في العمود A  بداية من الصف 7  إذا قمت بتغيير هذه الكلمات المفتاحية عليك تعديلها داخل الكود أيضا  لذلك ييفضل أن تحرص دائما على وجود هذه الكلمات في أماكنها لتضمن عمل الكود بشكل صحيح

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim SrcWS As Worksheet, Irow As Long, tmp As Long, n As Long, OnRng As Long, tbl As Long, i As Long
    
    Const StarTBL As String = "الاسم"
    Const EndTBL As String = "المختص"
    
    On Error GoTo ErrorData
    Set SrcWS = Me
    Irow = SrcWS.Cells(SrcWS.Rows.Count, "B").End(xlUp).Row
    SetApp False
    
    For tmp = 6 To Irow
        If Not SrcWS.Cells(tmp, "A").MergeCells Then SrcWS.Cells(tmp, "A").ClearContents
    Next tmp
    
    n = 1
    tmp = 6
    Do While tmp <= Irow
        If Trim(SrcWS.Cells(tmp, "B").Value) = StarTBL Then
            OnRng = tmp + 1
            Do While Trim(SrcWS.Cells(tmp, "B").Value) <> EndTBL And tmp <= Irow
                tmp = tmp + 1
            Loop
            tbl = tmp - 3
            For i = OnRng To tbl
                If Not SrcWS.Cells(i, "A").MergeCells And SrcWS.Cells(i, "A").Value = "" Then
                    SrcWS.Cells(i, "A").Value = n
                    n = n + 1
                End If
            Next i
        End If
        tmp = tmp + 1
    Loop
    
    SetApp True
    Exit Sub
ErrorData:
End Sub
                                                                               
Private Sub SetApp(ByVal Enable As Boolean)
    Application.ScreenUpdating = Enable
    Application.EnableEvents = Enable
    Application.Calculation = IIf(Enable, xlCalculationAutomatic, xlCalculationManual)
End Sub

 

 

 

 

 

 

 

 

مطلوب ترقيم تلقائى لا يتأثر بحذف الصفوف.xlsb

[algammal]

أخي الكريم الأستاذ / محمد هشام

جزاكم الله خيرا وبارك الله فيكم وأسبغ عليكم من فضله

ماذا لو أضفت صفحات أخرى لهذا الملف وأردت أن تتم متابعة الترقيم التلقائي فيها

ما الذي يتم تعديله على الكود حتى أصل لترقيم الصفحات المضافة؟

وجزاكم الله عنا خير الجزاء وشكرا لسعة صدركم وزادكم الله علما 

تم تعديل ديسمبر 12 بواسطه algammal

[محمد هشام.]

ماذا تقصد بصفحات أخرى؟  هل أوراق عمل أخرى أو جداول  جديدة في نفس الورقة ؟

اذا كنت تقصد جداول فهذا ما يفعله الكود عند إظافة جدول يتضمن نفس الشروط

حاول تحديد و  نسخ  أي جدول بداية من صف عناوين الأعمدة  إلى غاية صف المختص ونسخه أسفل الجداول السابقة ستلاحظ  تحديث الترقيم تلقائيا 

[algammal]

أخي الكريم الأستاذ / محمد هشام

جزاكم الله خيرا وبارك الله فيكم 

خانة المسلسل اختفى منها حرف (م) وكلما كتبتها تختفي بمجرد الخروج من الخلية

أرجو مساعدتي في ظهور حرف (م) في خانة المسلسل

ولكم خالص الشكر والتقدير

[محمد هشام.]

For tmp = 6 To Irow
        If IsNumeric(SrcWS.Cells(tmp, "A").Value) Then
            SrcWS.Cells(tmp, "A").ClearContents
        End If
    Next tmp

 

مطلوب ترقيم تلقائى لا يتأثر بحذف الصفوف.xlsb

[algammal]

أخي الكريم الأستاذ / محمد هشام