وعليكم السلام أخي الكريم أحمد
جرب الكود التالي عله يفي بالغرض ..
الكود الأول يقوم بمسح البيانات الموجودة في العمود الأول في كل جدول مع مسح رقم الجدول ..
الكود الثاني يقوم بالترقيم بشكل تسلسلي لكل جدول ويكمل في الجدول الذي يليه ، مع فرض أن عدد صفوف كل جدول ثابتة (6 صفوف)

Sub Clear_Data_From_Tables()
    Dim r As Range, c As Range, rFirst As Range
    Set r = ActiveWorkbook.Worksheets("Sheet1").Range("A1:J100")
    Set c = r.Find("s", , , , xlByColumns)
    If rFirst Is Nothing Then Set rFirst = c
    Do While Not c Is Nothing
        c.Offset(1).Resize(6).ClearContents
        c.Offset(, 1).ClearContents
        Set c = r.FindNext(After:=c)
        If c.Address = rFirst.Address Then Exit Do
    Loop
End Sub

Sub Put_Sequence_To_Multiple_Tables_FindNext_Do_While_Loop()
    Dim w, r As Range, c As Range, rFirst As Range, m As Long, n As Long
    Set r = ActiveWorkbook.Worksheets("Sheet1").Range("A1:J100")
    m = 1: n = 1
    Set c = r.Find("s", , , , xlByColumns)
    If rFirst Is Nothing Then Set rFirst = c
    Do While Not c Is Nothing
        w = Evaluate("ROW(" & m & ":" & m + 5 & ")")
        c.Offset(1).Resize(UBound(w, 1)).Value = w
        c.Offset(, 1).Value = n
        m = m + 6: n = n + 1
        Set c = r.FindNext(After:=c)
        If c.Address = rFirst.Address Then Exit Do
    Loop
End Sub

وجزيت خيراً أخي العزيز أحمد شريف ومشكور على كلماتك الطيبة
والحمد لله الذي بنعمته تتم الصالحات

تم نقل الموضوع لقسم إكسيل أسئلة وإجابات ... يرجى طرح السؤال في القسم المناسب