View Single Post
 
Old 06-15-2021, 01:56 AM
Shelley Lou Shelley Lou is offline Windows 10 Office 2016
Competent Performer
 
Join Date: Dec 2020
Posts: 170
Shelley Lou is on a distinguished road
Default VBA quote mark to insert after square bracket

Hi guys, I'm looking to update the macro below. In the word document attached, highlighted row, at the beginning of the definition the quote mark should insert after the square bracket. I also need to remove any punctuation at the end of the definition before the square bracket (the macro below does remove punctuation and replaces it with a semi-colon but I'm not sure how to tell it to remove punctuation if the sentence ends with a square bracket). Any help would be appreciated. Many thanks.

Definitions.docx

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
    'Remove colons'
    .Text = ":"
    .Font.Bold = True
    .Replacement.Text = ""
    .Execute Replace:=wdReplaceAll
  End With
   With orng.Find
    'Remove colons'
    .Text = ":"""
    .Replacement.Text = """"
    .Execute Replace:=wdReplaceAll
  End With
    With orng.Find
    'remove bold from spaces after the word means
    .Text = "means "
    .Replacement.Text = "means "
    .Replacement.Font.Bold = False
    .Execute Replace:=wdReplaceAll
  End With
   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
  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"
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  With orng.Find
    'Remove double quotes'
    .Text = """"
    .Replacement.Text = ""
    .Execute Replace:=wdReplaceAll
  End With
  Set orng = ActiveDocument.Range
  'Replace tab with space'
  With orng.Find
    .Text = "^t"
    .Replacement.Text = " "
    .Execute Replace:=wdReplaceAll
  End With
  Set orng = ActiveDocument.Range
  'Bold quotes
  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.Font.Bold = False
          orng.Characters.Last = vbTab
        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
  'Remove the words means from each definition and insert a tab'
  Set orng = ActiveDocument.Range
  With orng.Find
    .Text = "^tmeans"
    .Replacement.Text = "^t"
    .Execute Replace:=wdReplaceAll
  End With
  'Remove the words means and space before and insert a tab'
  Set orng = ActiveDocument.Range
  With orng.Find
    .Text = " ^tmeans"
    .Replacement.Text = "^t"
    .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
  With orng.Find
    'Remove colons'
    .Text = ":"""
    .Replacement.Text = """"
    .Execute Replace:=wdReplaceAll
  End With
  'Highligt tabs
  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
  'Insert semi-colon at end of sentences but not for and, but, or
    Set orng = ActiveDocument.Range
    With orng.Find
      .Text = ".^p"
      .Replacement.Text = "^p"
      .Execute Replace:=wdReplaceAll
      End With
    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"
              'do nothing
            Case Else
              .Characters.Last.InsertBefore ";"
          End Select
        End If
      End If
    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 Sub
Code:
Sub ResetFRParameters()
  With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
lbl_Exit:
  Exit Sub
End Sub
Reply With Quote