merge cells upto blank cells

[Rakesh]

Hi Guys,

I had bunch of client supplied word files, which single paragraph is divided into multiple cells.

Attached file for your reference.

What I right now doing is selecting the cells manually and merge the cells through Menu Bar/Table/Merge Cells and replacing paragraph return with space.


Can it possible to do it by macro?

If so it saves me a day!!!!

Thanks
Rakesh

[gmaxey]

This should get you close:

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oTbl As Table, oRow As Row, lngIndex As Long, lngCol As Long
Dim oRng As Range
Set oTbl = ActiveDocument.Tables(1)
  Set oRng = oTbl.Rows(1).Range
  Do
    Do
      oRng.MoveEnd wdRow, 1
    Loop Until Len(oRng.Rows.Last.Range) = 14
    For lngIndex = 2 To oRng.Rows.Count - 1
      For lngCol = 1 To 6
        oRng.Rows(1).Cells(lngCol).Range.Text = Trim(Left(oRng.Rows(1).Cells(lngCol).Range.Text, _
                  Len(oRng.Rows(1).Cells(lngCol).Range.Text) - 2) & " " & Left(oRng.Rows(lngIndex).Cells(lngCol).Range.Text, _
                  Len(oRng.Rows(lngIndex).Cells(lngCol).Range.Text) - 2))
      Next lngCol
    Next lngIndex
    For lngIndex = oRng.Rows.Count - 1 To 2 Step -1
      oRng.Rows(lngIndex).Delete
    Next lngIndex
    On Error GoTo lbl_Exit
    Set oRng = oRng.Rows.Last.Next.Range
  Loop
lbl_Exit:
  Exit Sub
  
End Sub