VBA code help: replacing punctuation

Shelley Lou · #1 06-17-2021, 09:20 AM

Hi, I would like to tidy up this code.

1. After each sentence the code runs to remove punctuation and replace with a semi-colon. It doesn't seem to work unless I put the .Text = ".^p" bit of the code to remove periods first though. Is there a better way to do this?
2. The code needs to remove punctuation before a square bracket at the end of sentences only. I have put the code in as .Text = ".]^p" etc. which removes punctuation, what I need is for the code that inserts the semi-colon, to search for square brackets and insert the semi-colon before the square bracket not after it.

I'm really not sure how to make this happen, can anyone help please.

Code:

 'Remove period from end of sentence
    Set orng = ActiveDocument.Range
    With orng.Find
    .Text = ".^p"
   .Replacement.Text = "^p"
   .Execute Replace:=wdReplaceAll
    End With
    'Remove period before square bracket at end of sentence
       Set orng = ActiveDocument.Range
    With orng.Find
      .Text = ".]^p"
      .Replacement.Text = "]^p"
      .Execute Replace:=wdReplaceAll
      End With
      'Insert semi-colon at end of sentences but not for and, but, or, then
      Set orng = ActiveDocument.Range
    For Each Para In ActiveDocument.Paragraphs
    With Para.Range
      If Len(.Text) > 2 Then
        If Not .Characters.Last.Previous Like "[.!?:;]" Then
          Select Case .Words.Last.Previous.Words(1)
            Case "and", "but", "or", "then"
              'do nothing
            Case Else
              .Characters.Last.InsertBefore ";"
          End Select
        End If
      End If
    End With

macropod · #2 06-17-2021, 03:39 PM

Without seeing some sample content, it's hard to know exactly what needs to be done. Try:

Code:

Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
  With .Find
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Text = "[! ^13]@[!.\!\?:;]^13"
    .Replacement.Text = ""
    .Execute
  End With
  Do While .Find.Found = True
    Select Case Trim(.Words.First)
      Case "and", "but", "or", "then"
        'do nothing
      Case Else
      .Words.First.InsertAfter ";"
    End Select
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
End Sub

Shelley Lou · #3 06-20-2021, 01:26 AM

Hi Macropod, many thanks for the code. I'm having an error with 'Do While.Find.Found = True' - error says 'Method or data member not found'. I have inserted the full code I'm trying to get it to work in after your code.

Definition Test Doc.docx

Code:

'Remove punctuation and insert semi-colon at end of sentence
    Set orng = ActiveDocument.Range
    With orng.Find
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Text = "[! ^13]@[!.\!\?:;]^13"
   .Replacement.Text = ""
   .Execute Replace:=wdReplaceAll
    End With
    Do While .Find.Found = True
    Select Case Trim(.Words.First)
      Case "and", "but", "or", "then"
        'do nothing
      Case Else
      .Words.First.InsertAfter ";"
    End Select
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With

Code:

Sub DPU_Definitions()
Dim orng As Range
Dim Para As Paragraph
  Application.ScreenUpdating = False
   'Create placeholder.
  ActiveDocument.Range.InsertBefore vbCr
  ActiveDocument.Paragraphs(1).Range.Font.Bold = False
  'Convert numbers to text'
  ActiveDocument.Range.ListFormat.ConvertNumbersToText
  Set orng = ActiveDocument.Range
  ResetFRParameters
  With orng.Find
  'Delete white spaces before paragraph breaks
  .Text = "^w^p"
  .Replacement.Text = "^p"
  .Execute Replace:=wdReplaceAll
  End With
  With orng.Find
  'Delete white spaces after paragraph breaks
  .Text = "^p^w"
  .Execute Replace:=wdReplaceAll
  End With
  With orng.Find
  .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[:;, ^t]{1,5}means[:;, ]{1,5}"
    .Replacement.Text = "^t"
    .Replacement.Font.Bold = False
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
   With orng.Find
  Set orng = ActiveDocument.Range
  With orng.Find
  'Remove bold formatting from punctuation and para marks
    .Text = "[" & Chr(13) & ".;,:]"
    .MatchWildcards = True
    .Font.Bold = True
    .Replacement.Font.Bold = False
    .Execute Replace:=wdReplaceAll
  End With
  'Clear space before tabs
  With orng.Find
    .Text = " ^t"
    .Replacement.Text = "^t"
    .Replacement.Font.Bold = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  Set orng = ActiveDocument.Range
  'Insert Bold quotes for bold definition text at beginning of sentence
  With orng.Find
    .Text = ""
    .Replacement.Text = "^034^&^034"
    .Font.Bold = True
    .Format = True
    .MatchWildcards = True
    While .Execute
      If Not InStr(orng.Text, Chr(13)) Then
        While orng.Characters.Last = Chr(32)
          orng.Characters.Last.Font.Bold = False
          orng.End = orng.End - 1
        Wend
        orng.Text = Chr(34) & orng.Text & Chr(34)
        If orng.Characters.First.Previous = Chr(13) Then
          orng.Collapse wdCollapseEnd
          orng.Characters.Last = vbTab
          orng.Font.Bold = False
        Else
          orng.Collapse wdCollapseEnd
        End If
      End If
    Wend
  End With
  ResetFRParameters
  Set orng = ActiveDocument.Range
 'insert tab at beginning of paragraph with a bracket e.g. (a), (i), (1)
    With orng.Find
        .MatchWildcards = True
        .Text = "^13(\([a-z0-9]{1,}\))"
        .Replacement.Text = "^p^t\1"
        .Execute Replace:=wdReplaceAll
    End With
    'insert tab at beginning of paragraph e.g a), 1), i), 100 etc.
    With orng.Find
        .MatchWildcards = True
        .Text = "^13([a-z0-9\)]{1,})"
        .Replacement.Text = "^p^t\1"
        .Execute Replace:=wdReplaceAll
    End With
  Set orng = ActiveDocument.Range
 'Clears colons or commas after tabs.
  With orng.Find
    .Text = "[^t]([:\,]){1,}"
    .Replacement.Text = "^t"
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  'Clear space after tabs
  With orng.Find
    .Text = "^t "
    .Replacement.Text = "^t"
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  'Highligt tabs so user can check for errors when code has run
  Set orng = ActiveDocument.Range
   Options.DefaultHighlightColorIndex = wdYellow
  With orng.Find
    .Text = "^t"
    .Replacement.Text = "^t"
    .Replacement.Highlight = True
    .Execute Replace:=wdReplaceAll
  End With
  ResetFRParameters
  Set orng = ActiveDocument.Range
  With orng.Find
    .Text = "^t"
    Do While .Execute
      orng.Start = orng.Paragraphs(1).Range.Start
      If Len(.Text) - Len(Replace(.Text, vbTab, "")) > 1 Then orng.Characters.Last.Text = " "
      orng.Collapse wdCollapseEnd
    Loop
  End With
    'Remove punctuation and insert semi-colon at end of sentence
    Set orng = ActiveDocument.Range
    With orng.Find
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Text = "[! ^13]@[!.\!\?:;]^13"
   .Replacement.Text = ""
   .Execute Replace:=wdReplaceAll
    End With
    Do While .Find.Found = True
    Select Case Trim(.Words.First)
      Case "and", "but", "or", "then"
        'do nothing
      Case Else
      .Words.First.InsertAfter ";"
    End Select
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
    Next
    'Remove placeholder.
  ActiveDocument.Paragraphs(1).Range.Delete
  Set orng = ActiveDocument.Range
  With orng.Find
    .Text = "^13[A-Za-z]"
    .MatchWildcards = True
    Do While .Execute
      If orng.Paragraphs(2).Style = "Normal" And _
         orng.Paragraphs(2).Range.Characters(1).Font.Bold = False Then
         orng.Paragraphs(2).Range.InsertBefore vbTab
      End If
      orng.Collapse 0
    Loop
  End With
  Application.ScreenUpdating = True
lbl_Exit:
  Set orng = Nothing
  Exit Sub
  End With
  End With
End Sub

macropod · #4 06-20-2021, 06:31 PM

The code I posted previously take a different approach to the rest of your macro. Try:

Code:

Sub DPU_Definitions()
Application.ScreenUpdating = False
With ActiveDocument
  With .Range
    'Convert list numbers to text'
    .ListFormat.ConvertNumbersToText
    'Create placeholder.
    .InsertBefore vbCr
    .Paragraphs(1).Range.Font.Bold = False
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = True
      .Forward = True
      .MatchWildcards = False
      .Wrap = wdFindContinue
      'Delete white spaces before paragraph breaks
      .Text = "^w^p"
      .Replacement.Text = "^p"
      .Execute Replace:=wdReplaceAll
      'Delete white spaces after paragraph breaks
      .Text = "^p^w"
      .Execute Replace:=wdReplaceAll
      'Clean up definitions
      .MatchWildcards = True
      .Text = "[:;, ^t]{1,5}means[:;, ]{1,5}"
      .Replacement.Text = "^t"
      .Replacement.Font.Bold = False
      .Execute Replace:=wdReplaceAll
      'Remove bold formatting from punctuation and para marks
      .Text = "[^13.;,:]"
      .Replacement.Text = "^&"
      .Font.Bold = True
      .Execute Replace:=wdReplaceAll
      'Clear space before tabs
      .Text = "[ ^160]{1,}^t"
      .Replacement.Text = "^t"
      .Execute Replace:=wdReplaceAll
      'Insert Bold quotes for bold definition text at beginning of sentence
      .Text = ""
      .Replacement.Text = "^034^&^034"
      .Wrap = wdFindStop
    End With
    Do While .Find.Execute = True
      With .Duplicate
        Do While .Characters.Last = " "
          .Characters.Last.Delete
        Loop
        .InsertBefore Chr(147)
        .InsertAfter Chr(148)
        If .Characters.First.Previous = vbCr Then
          .InsertAfter vbTab
          .Characters.Last.Font.Bold = False
        End If
      End With
      .End = .End + 1
      .Collapse wdCollapseEnd
    Loop
    With .Find
      .Wrap = wdFindContinue
      'insert tab at beginning of paragraph with a bracket e.g. (a), a), (i), i), (1), 1)
      .Text = "^13([\(a-z0-9]@\))"
      .Replacement.Text = "^p^t\1"
      .Execute Replace:=wdReplaceAll
      'Clear colons or commas after tabs.
      .Text = "[^t]([:\,]){1,}"
      .Replacement.Text = "^t"
      .Execute Replace:=wdReplaceAll
      'Clear space after tabs
      .Text = "^t[ ^160]{1,}"
      .Execute Replace:=wdReplaceAll
      'Highligt tabs so user can check for errors when code has run
      .Wrap = wdFindStop
      .Text = "^t"
    End With
    Do While .Find.Execute = True
      With .Duplicate
        .HighlightColorIndex = wdYellow
        .Start = .Paragraphs(1).Range.Start
        If Len(.Text) - Len(Replace(.Text, vbTab, "")) > 1 Then .Characters.Last.Text = " "
      End With
      .Collapse wdCollapseEnd
    Loop
  End With
  With .Range
    'Remove punctuation and insert semi-colon at end of sentence
    .Find.Text = "[! ^13]@[!.\!\?:;]^13"
    Do While .Find.Execute = True
      With .Duplicate
        Select Case Trim(.Words.First)
          Case "and", "but", "or", "then"
            'do nothing
          Case Else
          .Words.First.InsertAfter ";"
        End Select
      End With
      .Collapse wdCollapseEnd
    Loop
  End With
  'Remove placeholder.
  .Paragraphs(1).Range.Delete
  With .Range
    'Prefix designated bold first words with a tab
    .Find.Text = "^13[A-Za-z]"
    Do While .Find.Execute = True
      With .Duplicate.Paragraphs.Last.Range
        If .Style = "Normal" Then
          If .Characters.First.Font.Bold = False Then .InsertBefore vbTab
        End If
      End With
      .Collapse wdCollapseEnd
    Loop
  End With
End With
End Sub

Shelley Lou · #5 06-21-2021, 12:43 AM

Hi Macropod, many thanks for updating this code for me, very much appreciated. There appears to be 2 message boxes that come up and it won't let me run the macro - MsgBox Chr(34) & .Text & Char(34), how can I amend these so I don't get the message box. Thanks.

Image.JPG

Code:

'Remove punctuation and insert semi-colon at end of sentence
    .Find.Text = "[! ^13]@[!.\!\?:;]^13"
    Do While .Find.Execute = True
      With .Duplicate
        MsgBox Chr(34) & .Text & Chr(34)
        Select Case Trim(.Words.First)
          Case "and", "but", "or", "then"
            'do nothing
          Case Else
          .Words.First.InsertAfter ";"
        End Select
      End With
      .Collapse wdCollapseEnd
    Loop
  End With
  'Remove placeholder.
  .Paragraphs(1).Range.Delete
  With .Range
    'Prefix designated bold first words with a tab
    .Find.Text = "^13[A-Za-z]"
    Do While .Find.Execute = True
        MsgBox Chr(34) & .Text & Chr(34)
      With .Duplicate.Paragraphs.Last.Range
        If .Style = "Normal" Then
          If .Characters.First.Font.Bold = False Then .InsertBefore vbTab
        End If
      End With
      .Collapse wdCollapseEnd
    Loop
  End With

macropod · #6 06-21-2021, 12:49 AM

I modified the code soon after posting to remove those - I was using them for testing.

Shelley Lou · #7 06-21-2021, 02:14 AM

Hi Macropod, I have removed the MsgBox lines in the code. Unfortunately the code is crashing Word with Not Responding and I have to End Task to break out of it. Any ideas?

macropod · #8 06-21-2021, 09:29 PM

OK, I've made a few small changes. Try it now.

Shelley Lou · #9 07-01-2021, 04:42 AM

Hi Macropod, apologies for the late response, I've been trying to get this code to work but it just crashing Word every time and I have to End Task, any ideas. Thanks

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
How to delete all the punctuation marks from a paragraph?	Jamal NUMAN	Word	3	02-26-2019 02:33 PM
punctuation order	fariz	Word	2	10-31-2016 12:57 AM
Need help with modifying a replacing font VBA code- similar task but subtle change	kissingfrogs2003	Word VBA	3	08-30-2016 11:42 AM
Replacing punctuation marks with footnotes	nufc89	Word	2	05-22-2015 03:15 PM
Punctuation	lexsper	Word	0	04-06-2015 07:26 AM