View Single Post
 
Old 06-17-2021, 11:48 PM
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 quote mark to insert after square bracket

Hi, many thanks for replying it is very much appreciated. Background is I house style documents, converted from pdf to word mostly, I copy the definitions part into a blank document then run the macro. Once I've checked for errors I run another macro that converts text to correct styles and inserts 2 column table, hence the tabs before non-bold sentences. I have attached a copy of the table document also. There is an issue where the definition starts with a), b) and not (a), (b). House style is Arial 10, 0pt before, 9pt after, line spacing At Least 15. I've tried to comment as much as possible in the BEFORE MACRO IS RUN document. Thank you for looking at this.

BEFORE MACRO IS RUN definitions test 1.docx
AFTER MACRO IS RUN definitions test 2.docx
CONVERTED TO TABLE FORMAT definitions test 3.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 and add double quotes'
    .Text = ":"""
    .Replacement.Text = """"
    .Execute Replace:=wdReplaceAll
  End With
    With orng.Find
    'remove bold from spaces after athe word means
    .Text = "means "
    .Replacement.Text = "means "
    .Replacement.Font.Bold = True
    .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
  '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.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 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 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
    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
Code:
Sub DPU_TextToTables()
  Dim oBorder As Border
  Dim Para As Paragraph
    Selection.WholeStory
    Selection.ConvertToTable Separator:=wdSeparateByTabs, NumColumns:=2, _
    NumRows:=8, AutoFitBehavior:=wdAutoFitFixed
    With Selection.Tables(1)
        .Style = "Table Grid"
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = False
        With .Range
            .Font.Name = "Arial"
            .Font.Size = 10
            With .ParagraphFormat
                .SpaceBefore = 0
                .SpaceBeforeAuto = False
                .SpaceAfter = 9
                .SpaceAfterAuto = False
                .LineSpacingRule = wdLineSpaceAtLeast
                .LineSpacing = 15
                .LineUnitBefore = 0
                .LineUnitAfter = 0
            End With
        End With
        With .Columns(1)
            .PreferredWidth = InchesToPoints(2.7)
            .Select
            With Selection.ParagraphFormat
                .Alignment = wdAlignParagraphLeft
                .LeftIndent = InchesToPoints(1)
                .Style = "DefBold"
                End With
            For Each oBorder In .Borders
            oBorder.LineStyle = wdLineStyleNone
            Next oBorder
            End With
        With .Columns(2)
            .Select
            With Selection.ParagraphFormat
                .Alignment = wdAlignParagraphJustify
            End With
            .PreferredWidth = InchesToPoints(3.63)
            For Each oBorder In .Borders
                oBorder.LineStyle = wdLineStyleNone
            Next oBorder
           End With
           Call DPU_ApplyHeadingStylesToTableTable
    End With
End Sub
Reply With Quote