Microsoft Office Forums - View Single Post - How to Draw a line at every change in date in the document

Guessed · 10-23-2022, 11:29 PM

It appears that generally the paragraphs that should be in the row above are formatted with no space above. If we use that as the trigger to move the content up then these changes to the macro might get you most of the way there. There is at least one case where the conversion didn't add a paragraph mark so that might need a manual fix

Code:

Sub FixTable2()
  Dim r As Long, c As Long, RngSrc As Range, RngTgt As Range, aCell As Cell
  With ActiveDocument.Tables(1)
    For r = 3 To .Rows.Count
      For Each aCell In .Rows(r).Cells
        If aCell.Range.Characters(1) = vbCr Then aCell.Range.Characters(1).Delete
        If aCell.Range.Paragraphs(1).SpaceBefore = 0 And aCell.Range.Paragraphs.Count > 1 Then
          Set RngSrc = aCell.Range.Paragraphs(1).Range
          RngSrc.MoveEnd Unit:=wdCharacter, Count:=-1
          RngSrc.Select
          Set RngTgt = .Cell(r - 1, aCell.ColumnIndex).Range
          RngTgt.MoveEnd Unit:=wdCharacter, Count:=-1
          RngTgt.InsertAfter vbCr & RngSrc.Text
          aCell.Range.Paragraphs(1).Range.Delete
        End If
      Next aCell
    Next
    .Rows.HeightRule = wdRowHeightAuto
    .Range.Paragraphs.LeftIndent = 0
    .Range.Paragraphs.RightIndent = 0
    .Range.Paragraphs.FirstLineIndent = 0
  End With
End Sub

Does this version get you closer to the desired target?