Option Explicit
Sub splitTableByEachRow()
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
r = 1
With Selection
Set rng = .Range
DoWhile (.Information(wdWithInTable))
.SplitTable
Set cel = Selection.Document.Tables(r).Cell(1, 8)
If cel.Range.InlineShapes.Count > 0ThenElseIf Selection.Document.Tables(r).Rows.Count > 1Then _
Set cel = Selection.Document.Tables(r).Cell(2, 8)
EndIf
s = .Start: e = .End
rng.SetRange s, s
If cel.Range.InlineShapes.Count > 0Then
cel.Range.InlineShapes(1).Select
.Cut
s1 = .Start: e1 = .End
If s1 > s ThenDoWhile (rng.Information(wdWithInTable))
s1 = s1 - 1
rng.SetRange s1, s1
Loop
ElseIf s1 < s ThenDoWhile (rng.Information(wdWithInTable))
s1 = s1 + 1
rng.SetRange s1, s1
LoopEndIf
rng.Select
.Paste
If .Previous.InlineShapes.Count > 0ThenWith .Previous.InlineShapes(1)
.LockAspectRatio = msoTrue
.Height = 200EndWithElse
.MoveRight wdCharacter, 1, wdExtend
With .InlineShapes(1)
.Height = .Height + 181
.Width = .Width + 181EndWithEndIf
.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Document.Tables(r).Columns(8).Cells.Delete
EndIf
r = r + 1If Selection.Document.Tables(r).Rows.Count > 1Then
Selection.Document.Tables(r).Rows(2).Select
ElseExitDoEndIfLoopEndWith
Beep
End Sub
留言