Option Explicit



Sub zzz()

Dim d As Document
Dim t As Table
Dim rcnt As Integer, rn As Integer, ccnt As Integer, cn As Integer
Dim c As Cell
Dim rng As Range
Dim n As Integer
Dim cm As Comment



    Set d = ThisDocument
    
    
    
    For Each t In d.Tables
        If (t.Cell(1, 1).Shading.BackgroundPatternColorIndex = wdRed) Then d.Comments.Add t.Range, "SplitTable"
    Next t
    
    
    
l1:

    
    For Each cm In d.Comments
        If (cm.Range = "SplitTable") Then
            Set t = cm.Scope.Tables(1)
            rcnt = t.Rows.Count
            ccnt = t.Columns.Count
            rn = 1
            cn = 1
            Set c = t.Cell(rn, cn)
            
            For rn = 1 To rcnt
                For cn = 1 To ccnt
                    If (t.Cell(rn, cn).Shading.BackgroundPatternColorIndex = wdRed) Then
                        t.Cell(rn, cn).Shading.BackgroundPatternColorIndex = wdAuto
                    Else
                        If (rn > 1 And rn < rcnt) Then
                            t.Cell(rn - 1, 1).Select
                            Selection.SelectRow
                            Selection.InsertRowsBelow 1
    
                            For n = 1 To ccnt
                                t.Cell(rn, n).Range.Text = VBA.Trim(VBA.Str(n))
                            Next n
                            
                            Set t = cm.Scope.Tables(1)
                            t.Split rn    '<----------------------------ОШИБКА ПРОИСХОДИТ ЗДЕСЬ!!!!!!!!!!!!!!!!!!---------------------
                            
                            cm.Scope.Tables(2).Cell(1, 1).Select
                            Selection.SelectRow
                            Selection.Rows.HeadingFormat = True
                            
                            Set rng = t.Range
                            rng.Collapse wdCollapseEnd
                            rng.Paragraphs(1).Range.Font.Size = 1
                            rng.Paragraphs(1).Format.LineSpacingRule = wdLineSpaceExactly
                            rng.Paragraphs(1).Format.LineSpacing = 0.7
                            rng.Paragraphs(1).Format.SpaceAfter = 0
                            rng.Paragraphs(1).Format.SpaceBefore = 0
                            t.Borders(wdBorderBottom).Visible = False
                            cm.DeleteRecursively
                            GoTo l1
                        End If
                    End If
                Next cn
            Next rn
        End If

    Next cm
    

    


End Sub