Sub CellMerge()
Application.ScreenUpdating = False
Dim Tbl As Table, Cll As Cell
For Each Tbl In ActiveDocument.Tables
  For Each Cll In Tbl.Range.Cells
    With Cll
      If .ColumnIndex < Tbl.Columns.Count Then
        If .Borders(wdBorderBottom).LineStyle = wdLineStyleNone And _
          .Borders(wdBorderTop).LineStyle = wdLineStyleNone Then
          .Merge MergeTo:=Tbl.Cell(Row:=.RowIndex + 1, Column:=.ColumnIndex)
          .Merge MergeTo:=Tbl.Cell(Row:=.RowIndex - 1, Column:=.ColumnIndex)
        End If
      End If
    End With
  Next
Next
Application.ScreenUpdating = True
End Sub