VBA quote mark to insert after square bracket

Shelley Lou · #1 06-15-2021, 01:56 AM

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

Shelley Lou · #2 06-16-2021, 01:42 AM

Hi posted yesterday, is anyone able to help identify how to make VBA insert the quote mark after the square bracket as I can't seem to get it to work. Many thanks

gmayor · #3 06-16-2021, 03:31 AM

Based on your example make a wildcard search for
(\))?(\])
replace with
\1\2
you might find https://www.gmayor.com/document_batch_processes.htm useful -especially the replace from table list option

Shelley Lou · #4 06-16-2021, 04:45 AM

Where should I insert this in the VBA? Bit confused as nothing is working

Shelley Lou · #5 06-17-2021, 01:34 AM

I have identified that this is the part of the code that inserts bold quotes around the main bold definition text at the beginning. Can someone help me with the code so that if the definition starts with a square bracket that the quote inserts after the square bracket and not before (see doc at beginning of post). I've tried Graham's search and replace but it doesn't seem to work. Thanks

Code:

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

Guessed · #6 06-17-2021, 07:59 PM

Shelley Lou

This code is getting more and more complex and will result in a document that is less and less well formatted. I think we need to get back to first principles for this task and use styles (paragraph and character) to format this. Can you post a Before and After example showing ALL the possible variations you need the macro to deal with.

If we can see what you want to achieve, it is easier to code from scratch than it is to fiddle with individual components in your find and replace series.

Shelley Lou · #7 06-17-2021, 11:48 PM

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

Guessed · #8 06-18-2021, 02:59 AM

I didn't fiddle with the semi colon endings because your very first 'fixed' paragraph broke the rule of [sentences to end with a semi-colon]. - so it wasn't particularly clear what you wanted there. This code assumes your table formatting is done by the Table Style definitions. I've attached a result document with table style defined to match your look.

Code:

Sub DefinitionsTabulator()
  Dim aRng As Range, aTbl As Table, aPara As Paragraph, aCell As Cell
  Set aRng = ActiveDocument.Range

  For Each aPara In aRng.Paragraphs
    aPara.Range.Words.Last.Font.Reset     'remove bold from paragraph marks and autonumbers
  Next aPara

  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[:;, ^t]{1,5}means[:;, ]{1,5}"
    .Replacement.Text = "^t"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    
    .Text = "[ :]{1,5}^13"
    .Replacement.Text = ":^p"
    .Execute Replace:=wdReplaceAll
    
    Set aRng = ActiveDocument.Range
    aRng.ListFormat.ConvertNumbersToText
    
    .Text = "^13([a-z])\)"
    .Replacement.Text = "^13(\1)"
    .Execute Replace:=wdReplaceAll
    
    .Text = "^13(?)"
    .Replacement.Text = "|\1"
    .MatchWildcards = True
    .Font.Bold = False
    .Execute Replace:=wdReplaceAll
    
    .Text = "(?)^t"
    .Replacement.Text = "\1zzTabzz"
    .Font.Bold = False
    .Execute Replace:=wdReplaceAll
  End With
  
  Set aRng = ActiveDocument.Range
  Set aTbl = aRng.ConvertToTable(Separator:=wdSeparateByTabs, NumColumns:=2, AutoFitBehavior:=wdAutoFitFixed)
  With aTbl
    .Style = "Table Grid Light"     'choose a table style that matches your preferred table look
    .ApplyStyleHeadingRows = False
    .ApplyStyleLastRow = False
    .ApplyStyleFirstColumn = True     'make sure the table style has a bold first column
    .ApplyStyleLastColumn = False
    .Range.Style = wdStyleNormal
    For Each aCell In .Columns(1).Cells
      If aCell.Range.Characters.First = "[" Then
        aCell.Range.Characters.First.InsertAfter Text:=""""
        aCell.Range.Characters.Last.InsertBefore Text:=""""
      Else
        aCell.Range.Characters.First.InsertBefore Text:=""""
        aCell.Range.Characters.Last.InsertBefore Text:=""""
      End If
    Next aCell
  End With
  
  'Reinstate the tabs and paragraphs
  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .MatchWildcards = False
    .Text = "|"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    
    .Text = "zzTabzz"
    .Replacement.Text = "^t"      'or a space if you prefer
    .Execute Replace:=wdReplaceAll
  End With
End Sub

Your style definitions should be in your template already and not fiddled by the macro. Try to avoid overly complicating the formatting by using vba code that SHOULD be done by the already existing style definition - just use the vba to apply the style.

Shelley Lou · #9 06-18-2021, 03:34 AM

Hi Andrew, thanks for looking at this much appreciated. Just looking through the first part, after wording 'remove bold from paragraph marks and autonumbers what do the functions do as I would like to put in comments to remind me what the functions are, will have a test of some docs see how it works

Shelley Lou · #10 06-18-2021, 06:41 AM

Hi Andrew, I've run the macro but there are some issues. I've attached a word doc showing these. For each sub-para e.g. (a), (i), (A), (1) these need to be in their own row individually. Not sure where I should be applying the column styles. For column 1 it will be "DefBold" and column 2 will be 'Definition Level 1'. Also for formatting the table for column width, no border etc. as in my table macro, I've inserted in various spaces but nothing seems to work.

VBA Defs doc.docx

Guessed · #11 06-20-2021, 05:48 AM

I think it is a bad idea to put the sub-paras in different rows. However, I've added that in as an option line so you can choose to have it. I've also tinkered to size the columns and add some comments. The square brackets on the ends of lines fail to find when they are formfield results - are the formfields just something you added for markup reasons or are they in your real documents?

Code:

Sub DefinitionsTabulator()
  Dim aRng As Range, aTbl As Table, aPara As Paragraph, aCell As Cell
  Set aRng = ActiveDocument.Range

  For Each aPara In aRng.Paragraphs
    aPara.Range.Words.Last.Font.Reset     'remove bold from paragraph marks and autonumbers
  Next aPara

  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[:;, ^t]{1,5}means[:;, ]{1,5}"     'replace means with a tab
    .Replacement.Text = "^t"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    
    .Text = "[ ]{2,9}"          'multiple spaces reduced to one
    .Replacement.Text = " "
    .Execute Replace:=wdReplaceAll
    
    Set aRng = ActiveDocument.Range
    aRng.ListFormat.ConvertNumbersToText    'make lists hard coded
    
    .Text = "^w^p"             'paragraphs ending with whitespace have spaces removed
    .Replacement.Text = "^p"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
    
    .Text = "]^p"               'paragraphs ending with ], add semi-colon in front of ]
    .Replacement.Text = ";]^p"
    .Execute Replace:=wdReplaceAll
    
    .Text = " ([;:,]{1,5})"    'space before punctuation removed
    .Replacement.Text = "\1"
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    
    .Text = "^13([a-z])\)"          'make sure lists with unopened brackets a) get opening bracket (a)
    .Replacement.Text = "^13(\1)"
    .Execute Replace:=wdReplaceAll
    
    .Text = "^13(?)"              'If paragraph starts non-bold
    '.Replacement.Text = "|\1"     'Option: keep all paragraphs in a definition in one row
    .Replacement.Text = "^p^t\1" 'Option: if you want separate rows per paragraph
    .MatchWildcards = True
    .Font.Bold = False
    .Execute Replace:=wdReplaceAll
    
    .Text = "([!^13])^t"                 'find tabs preceded by non-bold character other than a carriage return
    .Replacement.Text = "\1zzTabzz"      'replace with a replaceable unique string
    .Font.Bold = False
    .Execute Replace:=wdReplaceAll
  End With
  
  Set aRng = ActiveDocument.Range
  Set aTbl = aRng.ConvertToTable(Separator:=wdSeparateByTabs, NumColumns:=2, AutoFitBehavior:=wdAutoFitFixed)
  With aTbl
    .Style = "Table Grid Light"     'choose a table style that matches your preferred table look
    .ApplyStyleHeadingRows = False
    .ApplyStyleLastRow = False
    .ApplyStyleFirstColumn = True     'make sure the table style has a bold first column
    .ApplyStyleLastColumn = False
    .ApplyStyleRowBands = False
    .Range.Style = "Definition Level 1"
    For Each aCell In .Columns(1).Cells
      aCell.Range.Style = "DefBold"
      If aCell.Range.Characters.First = "[" Then
        aCell.Range.Characters.First.InsertAfter Text:=""""
        aCell.Range.Characters.Last.InsertBefore Text:=""""
      ElseIf Len(aCell.Range.Text) > 2 Then
        aCell.Range.Characters.First.InsertBefore Text:=""""
        aCell.Range.Characters.Last.InsertBefore Text:=""""
      End If
    Next aCell
    .Columns.PreferredWidthType = wdPreferredWidthPoints
    .Columns.PreferredWidth = InchesToPoints(2.7)
    .Columns(2).PreferredWidth = InchesToPoints(3.63)
  End With
  
  'Reinstate the tabs and paragraphs
  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .MatchWildcards = False
    .Text = "|"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    
    .Text = "zzTabzz"
    .Replacement.Text = "^t"      'or a space if you prefer
    .Execute Replace:=wdReplaceAll
  End With
  
  'Remove all local formatting
  ActiveDocument.Range.Font.Reset
End Sub

Shelley Lou · #12 06-20-2021, 06:49 AM

Hi Andrew, many thanks for this revised code, this is really start to take shape now. I have also inserted some code for the table to have no border. Our house style requires the separate rows so many thanks for that coding it works. I have a further macro that updates (a), (A) etc. to the correct auto number style which will be called at the end of this macro.

House style requires square brackets to be in form fields which is an action I usually perform right at the end of converting so not needed for this macro.

I've run the macro several times and it seems the only command left to perform is to delete any periods at the end of sentences in column 2 and replace with a semi-colon, or where punctuation is missing at the end of the sentence to insert a semi-colon (except where there are colons) except for the words 'and', 'or', 'but', 'then'. Any ideas how I can insert this into the code?

Shelley Lou · #13 06-22-2021, 06:47 AM

Hi Andrew, I've been running the code on some test documents and I've come across a couple of issues that the macro isn't picking up.

1. After the Bold Definition text, if there is a bold space and not a tab the macro puts the whole definition into column 1.
2. If the Bold Definition text is on a line on its own and sub-levels (a), (b) etc. are on the next line the macro doesn't pick this up and puts (a) into column 1.
3. If the word 'means' appears additionally in the sentence the macro is deleting the word and inserting a tab, e.g. in relation to any group company means any other company

Is there something we could add to the code to stop this happening?
Thanks, Shelley

Before Macro TEST DOC.docx

After Macro TEST DOC.docx

Code:

Sub DPU_DefinitionTabulator()
  Dim aRng As Range, aTbl As Table, aPara As Paragraph, aCell As Cell, oBorder As Border
  Set aRng = ActiveDocument.Range
  For Each aPara In aRng.Paragraphs
    aPara.Range.Words.Last.Font.Reset     'remove bold from paragraph marks and autonumbers
  Next aPara
  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[:;, ^t]{1,5}means[:;, ]{1,5}"     'replace means with a tab
    .Replacement.Text = "^t"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    
    .Text = "[ ]{2,9}"          'multiple spaces reduced to one
    .Replacement.Text = " "
    .Execute Replace:=wdReplaceAll
    
    Set aRng = ActiveDocument.Range
    aRng.ListFormat.ConvertNumbersToText    'make lists hard coded
    
    .Text = "^w^p"             'paragraphs ending with whitespace have spaces removed
    .Replacement.Text = "^p"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
    
    .Text = ".^p"               'paragraphs ending with ], add semi-colon in front of ]
    .Replacement.Text = ";^p"
    .Execute Replace:=wdReplaceAll
      
    .Text = ".]^p"               'paragraphs ending with ], add semi-colon in front of ]
    .Replacement.Text = ";]^p"
    .Execute Replace:=wdReplaceAll
    
    .Text = " ([;:,]{1,5})"    'space before punctuation removed
    .Replacement.Text = "\1"
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    
    .Text = "^13([a-z])\)"          'make sure lists with unopened brackets a) get opening bracket (a)
    .Replacement.Text = "^13(\1)"
    .Execute Replace:=wdReplaceAll
    
    .Text = "^13(?)"              'If paragraph starts non-bold
    '.Replacement.Text = "|\1"     'Option: keep all paragraphs in a definition in one row
    .Replacement.Text = "^p^t\1" 'Option: if you want separate rows per paragraph
    .MatchWildcards = True
    .Font.Bold = False
    .Execute Replace:=wdReplaceAll
    
    .Text = "([!^13])^t"                 'find tabs preceded by non-bold character other than a carriage return
    .Replacement.Text = "\1zzTabzz"      'replace with a replaceable unique string
    .Font.Bold = False
    .Execute Replace:=wdReplaceAll
  End With
  
  Set aRng = ActiveDocument.Range
  Set aTbl = aRng.ConvertToTable(Separator:=wdSeparateByTabs, NumColumns:=2, AutoFitBehavior:=wdAutoFitFixed)
  With aTbl
    .Style = "Table Grid Light"     'choose a table style that matches your preferred table look
    .ApplyStyleHeadingRows = False
    .ApplyStyleLastRow = False
    .ApplyStyleFirstColumn = True     'make sure the table style has a bold first column
    .ApplyStyleLastColumn = False
    .ApplyStyleRowBands = False
    .Range.Style = "Definition Level 1"
    For Each aCell In .Columns(1).Cells
      aCell.Range.Style = "DefBold"
      If aCell.Range.Characters.First = "[" Then
        aCell.Range.Characters.First.InsertAfter Text:=""""
        aCell.Range.Characters.Last.InsertBefore Text:=""""
      ElseIf Len(aCell.Range.Text) > 2 Then
        aCell.Range.Characters.First.InsertBefore Text:=""""
        aCell.Range.Characters.Last.InsertBefore Text:=""""
      End If
    Next aCell
    .Columns.PreferredWidthType = wdPreferredWidthPoints
    .Columns.PreferredWidth = InchesToPoints(2.7)
    .Columns(2).PreferredWidth = InchesToPoints(3.63)
    For Each oBorder In .Borders
    oBorder.LineStyle = wdLineStyleNone
    Next oBorder
    End With
  
  'Reinstate the tabs and paragraphs
  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .MatchWildcards = False
    .Text = "|"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    
    .Text = "zzTabzz"
    .Replacement.Text = "^t"      'or a space if you prefer
    .Execute Replace:=wdReplaceAll
  End With
  
  'Remove all local formatting
  ActiveDocument.Range.Font.Reset
  Call DPU_ApplyHeadingStylesToTableTable
End Sub

Code:

Sub DPU_ApplyHeadingStylesToTableTable()
Application.ScreenUpdating = False
Dim r As Long, i As Long
With ActiveDocument.Tables(1)
  For r = 1 To .Rows.Count
    With .Cell(r, 2).Range
      If .Characters.First <> "(" Then
        .Style = "Definition Level 1"
      Else
        i = Asc(Split(Split(.Text, "(")(1), ")")(0))
        Select Case i
          Case 97 To 104, 106 To 117, 119, 121 To 122: .Style = "Definition Level 2" 'LowercaseLetter
          Case 105, 118, 120: .Style = "Definition Level 3" 'LowercaseRoman
          Case 65 To 90: .Style = "Definition Level 4" 'UppercaseLetter
          Case 48 To 57: .Style = "Definition Level 5" 'Arabic
        End Select
        .Collapse wdCollapseStart
        .MoveEndUntil " "
        .End = .End + 1
        .Delete
      End If
    End With
  Next
End With

Shelley Lou · #14 06-25-2021, 12:41 AM

I'm posting again in the hope I can resolve a couple of issues with the macro below.

Before Macro TEST DOC.docx
After Macro TEST DOC.docx

1. When converting pdfs to word, the definitions may or may not contain the word 'means' after the main bold definition text at the start of the sentence. The macro currently only looks for the word 'means' and deletes and inserts a tab. What I would like is if after the bold text and it is just a space and/or colon space without the word 'means' that the space and/or colon space is replaced with a tab otherwise the whole definition ends up in column 1.

2. If the word 'means' appears additionally in the sentence the macro is deleting the word and inserting a tab, e.g. in relation to any group company means any other company (see attached documents). Is there something I could add to the code below to prevent this from happening?

Code:

With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
      
    .Text = "[:;, ^t]{1,5}means[:;, ]{1,5}"     'replace means with a tab
    .Replacement.Text = "^t"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll

3. If the Bold Definition text is on a line on its own and sub-levels (a), (b) etc. are on the next line, the macro doesn't pick this up and puts (a) into column 1. It also happens if after the bold text the sentence starts with a sub-level (a), I really can't fathom out how to get this to work properly.

This is the whole macro:

Code:

Sub DPU_DefinitionTabulator()
  Dim aRng As Range, aTbl As Table, aPara As Paragraph, aCell As Cell, oBorder As Border
  Set aRng = ActiveDocument.Range
  For Each aPara In aRng.Paragraphs
    aPara.Range.Words.Last.Font.Reset     'remove bold from paragraph marks and autonumbers
  Next aPara
  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
      
    .Text = "[:;, ^t]{1,5}means[:;, ]{1,5}"     'replace means with a tab
    .Replacement.Text = "^t"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    
    .Text = "[ ]{2,9}"          'multiple spaces reduced to one
    .Replacement.Text = " "
    .Execute Replace:=wdReplaceAll
        
    Set aRng = ActiveDocument.Range
    aRng.ListFormat.ConvertNumbersToText    'make lists hard coded
    
    .Text = "^w^p"             'paragraphs ending with whitespace have spaces removed
    .Replacement.Text = "^p"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
    
    .Text = ".^p"               'paragraphs ending with . add semi-colon
    .Replacement.Text = ";^p"
    .Execute Replace:=wdReplaceAll
      
    .Text = ".]^p"               'paragraphs ending with ] add semi-colon in front of ]
    .Replacement.Text = ";]^p"
    .Execute Replace:=wdReplaceAll
    
    .Text = " ([;:,]{1,5})"    'space before punctuation removed
    .Replacement.Text = "\1"
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    
    .Text = "^13([a-z])\)"          'make sure lists with unopened brackets a) get opening bracket (a)
    .Replacement.Text = "^13(\1)"
    .Execute Replace:=wdReplaceAll
    
    .Text = "^13(?)"              'If paragraph starts non-bold
    '.Replacement.Text = "|\1"     'Option: keep all paragraphs in a definition in one row
    .Replacement.Text = "^p^t\1" 'Option: if you want separate rows per paragraph
    .MatchWildcards = True
    .Font.Bold = False
    .Execute Replace:=wdReplaceAll
    
    .Text = "([!^13])^t"                 'find tabs preceded by non-bold character other than a carriage return
    .Replacement.Text = "\1zzTabzz"      'replace with a replaceable unique string
    .Font.Bold = False
    .Execute Replace:=wdReplaceAll
  End With
  
  Set aRng = ActiveDocument.Range
  Set aTbl = aRng.ConvertToTable(Separator:=wdSeparateByTabs, NumColumns:=2, AutoFitBehavior:=wdAutoFitFixed)
  With aTbl
    .Style = "Table Grid Light"     'choose a table style that matches your preferred table look
    .ApplyStyleHeadingRows = False
    .ApplyStyleLastRow = False
    .ApplyStyleFirstColumn = True     'make sure the table style has a bold first column
    .ApplyStyleLastColumn = False
    .ApplyStyleRowBands = False
    .Range.Style = "Definition Level 1"
    For Each aCell In .Columns(1).Cells
      aCell.Range.Style = "DefBold"
      If aCell.Range.Characters.First = "[" Then
        aCell.Range.Characters.First.InsertAfter Text:=""""
        aCell.Range.Characters.Last.InsertBefore Text:=""""
      ElseIf Len(aCell.Range.Text) > 2 Then
        aCell.Range.Characters.First.InsertBefore Text:=""""
        aCell.Range.Characters.Last.InsertBefore Text:=""""
      End If
    Next aCell
    .Columns.PreferredWidthType = wdPreferredWidthPoints
    .Columns.PreferredWidth = InchesToPoints(2.7)
    .Columns(2).PreferredWidth = InchesToPoints(3.63)
    For Each oBorder In .Borders
    oBorder.LineStyle = wdLineStyleNone
    Next oBorder
    End With
  
  'Reinstate the tabs and paragraphs
  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .MatchWildcards = False
    .Text = "|"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    
    .Text = "zzTabzz"
    .Replacement.Text = "^t"      'or a space if you prefer
    .Execute Replace:=wdReplaceAll
  End With
  
  'Remove all local formatting
  ActiveDocument.Range.Font.Reset
  'Call DPU_ApplyHeadingStylesToTableTable
End Sub

Really appreciate some help if possible. Thanks, Shelley

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Insert Block Quote into Numbered List	krose4088	Word	4	12-10-2020 02:29 PM
Delete blank paragraph below bold, end square bracket	Dave T	Word VBA	2	04-28-2019 11:00 PM
Remove repeated number after square bracket	jeffreybrown	Word VBA	8	12-04-2018 06:01 PM
Word 2010 - Remove square-bracket encased string in large document	IntestinalWorm	Word	1	06-20-2017 01:14 AM
Insert caption to graphic with square text wrapping	nothing_kills	Drawing and Graphics	7	01-20-2014 10:57 PM