Oscar Sun

                  Option Explicit

Sub splitTableByEachRowTitleed()
Dim r As Long, cel As Cell, s As Long, e As Long, s1 As Long, e1 As Long, rng As Range
Dim inlsp As InlineShape
Dim rw As Row
r = 1

With Selection
    Set rng = .Range
    Do While (.Information(wdWithInTable))
        .SplitTable
        
        Set rw = .Document.Tables(1).Rows(1)
        rw.Range.Copy
        .Document.Tables(.Document.Tables.Count).Range.Characters(1).Select
        .Collapse wdCollapseStart
        .Paste
        .Document.Tables(.Document.Tables.Count).Range.Characters(1).Select
        .Collapse wdCollapseStart
        .MoveLeft
        
        
        If Selection.Document.Tables(r).Rows.Count = 1 Then
            Set cel = Selection.Document.Tables(r).Cell(1, 8)
        Else
            Set cel = Selection.Document.Tables(r).Cell(2, 8)
        End If
        
        If cel.Range.InlineShapes.Count > 0 Then
        Else
            If Selection.Document.Tables(r).Rows.Count > 1 Then _
                Set cel = Selection.Document.Tables(r).Cell(2, 8)
        End If
        s = .Start: e = .End
        rng.SetRange s, s
        If cel.Range.InlineShapes.Count > 0 Then
             cel.Range.InlineShapes(1).Select
            .Cut
'            cel.Range.InlineShapes(1).Range.Cut ' 若要用Range則記得要DoEvents讓系統剪貼簿完成工作
'            DoEvents'或許剛開始還行，久了還是會出錯。還是用Selection物件才保險、萬無一失
            s1 = .Start: e1 = .End
            If s1 > s Then
                Do While (rng.Information(wdWithInTable))
                    s1 = s1 - 1
                    rng.SetRange s1, s1
                Loop
            ElseIf s1 < s Then
                Do While (rng.Information(wdWithInTable))
                    s1 = s1 + 1
                    rng.SetRange s1, s1
                Loop
            End If
            rng.Select
            .Paste
            If .Previous.InlineShapes.Count > 0 Then
                With .Previous.InlineShapes(1)
                    .LockAspectRatio = msoTrue
                    .Height = 200
                End With
            Else
                .MoveRight wdCharacter, 1, wdExtend
                With .InlineShapes(1)
                    '.LockAspectRatio = msoTrue
                    .Height = .Height + 181
                    .Width = .Width + 181
                End With
            End If
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
        End If
        Selection.Document.Tables(r).Columns(8).Cells.Delete
        r = r + 1
        If Selection.Document.Tables(r).Rows.Count > 3 Then'結束時，尚須修改。目前可以權且加幾空白列在最後一列後
            Selection.Document.Tables(r).Rows(3).Select
        Else
            Exit Do
        End If
    Loop
End With
Beep
End Sub