Sub Macro1()
Dim lngIndex As Integer
Dim oTbl As Table
Dim oRng As Range
Dim strText As String
Dim lngCol As Long
Dim varVal
  strText = InputBox("Enter text to move cell")
  Application.ScreenUpdating = False
  For Each oTbl In ActiveDocument.Tables
    For lngCol = 1 To oTbl.Columns.Count - 1 Step 2
      For lngIndex = 1 To oTbl.Rows.Count
        Set oRng = oTbl.Cell(lngIndex, lngCol).Range
        oRng.End = oRng.End - 1
        varVal = Split(oRng.Text, strText)
        If UBound(varVal) = 1 Then
          oRng.Text = Trim(varVal(1))
          oRng.Cells(1).Next.Range.Text = strText
        End If
      Next lngIndex
      DoEvents
    Next lngCol
  Next oTbl
  Application.ScreenUpdating = True
  MsgBox "Tables processed"
lbl_Exit:
  Set oTbl = Nothing
  Set oRng = Nothing
  Exit Sub
End Sub