I need to automate the merging of an unspecified number of rows located between asterisks

macropod · #7 01-16-2025, 01:45 AM

You should be able to reduce your current macro to:

Code:

Sub Reformat()
Application.ScreenUpdating = False
With ActiveDocument.Range
  .PasteAndFormat (wdFormatPlainText)
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Forward = True
    .Format = False
    .Text = "Self[!^13]@^13"
    .Replacement.Text = ""
    .Execute Replace:=wdReplaceAll
    .Text = "Portal[!^13]@^13"
    .Execute Replace:=wdReplaceAll
    .Text = "Not reg[!^13]@^13"
    .Execute Replace:=wdReplaceAll
    .Text = "This p[!^13]@^13"
    .Execute Replace:=wdReplaceAll
    .Text = "\(Edit\)"
    .Execute Replace:=wdReplaceAll
    .Text = "[01][0-9]:[03]0 [AP]M"
    .Execute Replace:=wdReplaceAll
    .Text = "#[0-9]{5}[!^13]@^13"
    .Execute Replace:=wdReplaceAll
    .Text = "[FM]\) "
    .Replacement.Text = "^&^l"
    .Execute Replace:=wdReplaceAll
    .Text = "[0-9]{2}[-/][0-9]{2}[-/][0-9]{4}"
    .Replacement.Text = "^13^&"
    .Execute Replace:=wdReplaceAll
    .Text = " " & vbTab
    .Replacement.Text = "*"
    .Execute Replace:=wdReplaceAll
  End With
End With
Application.ScreenUpdating = True
End Sub

For the document as attached, you should be able to use:

Code:

Sub Test()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
  With .PageSetup
    .TopMargin = InchesToPoints(0.5)
    .BottomMargin = InchesToPoints(0.5)
    .LeftMargin = InchesToPoints(0.5)
    .RightMargin = InchesToPoints(0.5)
    .Gutter = InchesToPoints(0)
  End With
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Forward = True
    .Format = False
    .Text = "^13"
    .Replacement.Text = "^l"
    .Execute Replace:=wdReplaceAll
    .Text = "^l[\*^t]"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    .Text = "^t"
    .Replacement.Text = ""
    .Execute Replace:=wdReplaceAll
    .Text = "^13^l"
    .Execute Replace:=wdReplaceAll
  End With
  Set Rng = .Duplicate
  With Rng
    .End = .End - 1
    .ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, AutoFitBehavior:=wdAutoFitFixed
    With .Tables(1)
      .Style = "Table Grid"
      .Columns.Add
      .PreferredWidthType = wdPreferredWidthPercent
      .PreferredWidth = 100
      .Columns(1).PreferredWidth = 100 / 3
      .Columns(2).PreferredWidth = 200 / 3
      .Rows.Alignment = wdAlignRowCenter
    End With
  End With
End With
Application.ScreenUpdating = True
End Sub

Assuming both work as desired, they can be combined into:

Code:

Sub Reformat()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
  With .PageSetup
    .TopMargin = InchesToPoints(0.5)
    .BottomMargin = InchesToPoints(0.5)
    .LeftMargin = InchesToPoints(0.5)
    .RightMargin = InchesToPoints(0.5)
    .Gutter = InchesToPoints(0)
  End With
  .PasteAndFormat (wdFormatPlainText)
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Forward = True
    .Format = False
    .Text = "Self[!^13]@^13"
    .Replacement.Text = ""
    .Execute Replace:=wdReplaceAll
    .Text = "Portal[!^13]@^13"
    .Execute Replace:=wdReplaceAll
    .Text = "Not reg[!^13]@^13"
    .Execute Replace:=wdReplaceAll
    .Text = "This p[!^13]@^13"
    .Execute Replace:=wdReplaceAll
    .Text = "\(Edit\)"
    .Execute Replace:=wdReplaceAll
    .Text = "[01][0-9]:[03]0 [AP]M"
    .Execute Replace:=wdReplaceAll
    .Text = "#[0-9]{5}[!^13]@^13"
    .Execute Replace:=wdReplaceAll
    .Text = "[FM]\) "
    .Replacement.Text = "^&^l"
    .Execute Replace:=wdReplaceAll
    .Text = "[0-9]{2}[-/][0-9]{2}[-/][0-9]{4}"
    .Replacement.Text = "^13^&"
    .Execute Replace:=wdReplaceAll
    .Text = " " & vbTab
    .Replacement.Text = "*"
    .Execute Replace:=wdReplaceAll
    .Text = "^13"
    .Replacement.Text = "^l"
    .Execute Replace:=wdReplaceAll
    .Text = "^l[\*^t]"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    .Text = "^t"
    .Replacement.Text = ""
    .Execute Replace:=wdReplaceAll
    .Text = "^13^l"
    .Execute Replace:=wdReplaceAll
  End With
  Set Rng = .Duplicate
  With Rng
    .End = .End - 1
    .ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, AutoFitBehavior:=wdAutoFitFixed
    With .Tables(1)
      .Style = "Table Grid"
      .Columns.Add
      .PreferredWidthType = wdPreferredWidthPercent
      .PreferredWidth = 100
      .Columns(1).PreferredWidth = 100 / 3
      .Columns(2).PreferredWidth = 200 / 3
      .Rows.Alignment = wdAlignRowCenter
    End With
  End With
End With
Application.ScreenUpdating = True
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Automate Row-wise and Column-wise Merging of Table Cells	macropod	Word Tables	0	11-15-2024 03:14 PM
Automate the filling in of the rows of a table	Muzan93	Word VBA	4	05-19-2021 10:55 PM
Removing rows when mail merging	Richystab	Mail Merge	3	12-07-2020 03:05 AM
Merging Rows - HELP please!	MessyJessy	Excel	7	01-14-2015 01:38 AM
merging rows and creating sub-rows	gib65	Excel	2	12-09-2011 02:09 PM