View Single Post
 
Old 06-20-2021, 01:26 AM
Shelley Lou Shelley Lou is offline Windows 10 Office 2016
Expert
 
Join Date: Dec 2020
Posts: 259
Shelley Lou is on a distinguished road
Default VBA code help: replacing punctuation

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
Reply With Quote