Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, Rng As Range
With ActiveDocument
  Set Rng = .Paragraphs.Last.Range
    With Rng
      If Len(.Text) > 1 Then
        .InsertAfter vbCr
        .Collapse wdCollapseEnd
      End If
    End With
  For i = .Tables.Count To 1 Step -1
    With .Tables(i).Range
      If .InlineShapes.Count > 0 Then
        .Cut
        With Rng
          .Paste
          .Paragraphs.First.Previous.Range.Characters.Last.InsertBefore vbCr
          .Start = .Paragraphs.First.Previous.Range.Start
          .Collapse wdCollapseStart
        End With
      End If
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub