Microsoft Office Forums

Go Back   Microsoft Office Forums > >
Reload this Page VBA to only remove word at beginning and not additional instances within the same paragraph VBA to only remove word at beginning and not additional instances within the same paragraph
Register FAQ

Reply
 
Thread Tools Display Modes
  #1  
Old 07-02-2021, 12:59 AM
Shelley Lou Shelley Lou is offline VBA to only remove word at beginning and not additional instances within the same paragraph Windows 10 VBA to only remove word at beginning and not additional instances within the same paragraph Office 2016
Expert
VBA to only remove word at beginning and not additional instances within the same paragraph 		 
Join Date: Dec 2020
Posts: 259
Shelley Lou is on a distinguished road
Default VBA to only remove word at beginning and not additional instances within the same paragraph
I have the following code that removes instances of the word 'means' that follow after the bold definition text. However, the macro also removes any additional word 'means' that may be within the same paragraph as normal text. What can I add to the code that would stop this from happening. Thanks

Remove the word means TEST DOC June 2021.docx

Code:
Sub DefMeans()
Dim aRng As Range, aPara As Paragraph
  Set aRng = ActiveDocument.Range
  For Each aPara In aRng.Paragraphs
  Next aPara
  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[:;, ^t]{1,5}means[:;, ]{1,5}"
    .Replacement.Text = "^t"
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
End With
End Sub

Reply With Quote
  #2  
Old 07-02-2021, 03:27 AM
Guessed's Avatar
Guessed Guessed is offline VBA to only remove word at beginning and not additional instances within the same paragraph Windows 10 VBA to only remove word at beginning and not additional instances within the same paragraph Office 2016
Expert
  
Join Date: Mar 2010
Location: Canberra/Melbourne Australia
Posts: 4,159
Guessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant future
Default
Shelley

I'm expecting you to come up with some of the logic since you have been given oodles of code and don't appear to be experimenting on your own. Because you have never supplied a sample with EVERY condition in it at once, nobody has coded a complete solution.

A single search and replace won't do the full job because of the variations so you need to break it into steps.

Try to think of some stepwise logic that allows the macro to work out the difference between the 'means' you don't want and the 'means' you do want. Perhaps search for bold content and stick a unique tag after it to use as a reference point eg '</Bold>'. Then search on either side of that tag to get rid of punctuation or spaces right beside it. Then search for '</Bold>means' and replace it with a tab.

If you use the same stepwise logic for your other problem (definition followed by a paragraph mark) you can work out a series of steps that works there too.
__________________
Andrew Lockton
Chrysalis Design, Melbourne Australia
Reply With Quote
  #3  
Old 07-02-2021, 05:08 AM
Shelley Lou Shelley Lou is offline VBA to only remove word at beginning and not additional instances within the same paragraph Windows 10 VBA to only remove word at beginning and not additional instances within the same paragraph Office 2016
Expert
VBA to only remove word at beginning and not additional instances within the same paragraph 		 
Join Date: Dec 2020
Posts: 259
Shelley Lou is on a distinguished road
Default VBA to only remove word at beginning and not additional instances within the same paragraph
Hi Andrew, thank you for replying much appreciated as always. Believe me I have done nothing but experiment with your code below, I've been working on solutions since last week, I've exhausted Google and this forum. I do appreciate the code I have been given by this forum and I have tried to manipulate some of the code to do what I want but nothing seems to work, I am very inexperienced in coding and don't understand what most of it means. I will try the unique tag advice. I did wonder what the "zzTabzz" was in your code but this must be a unique tag. The table document is what your code currently does, there are just a couple of issues I need to resolve. Thanks for replying and for the pointers.

DEFINITIONS TEST DOC June 2021.docx
Table TEST DOC June 2021.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
    .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-Za-z0-9])\)"          '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
Reply With Quote
  #4  
Old 07-02-2021, 11:31 PM
Guessed's Avatar
Guessed Guessed is offline VBA to only remove word at beginning and not additional instances within the same paragraph Windows 10 VBA to only remove word at beginning and not additional instances within the same paragraph Office 2016
Expert
  
Join Date: Mar 2010
Location: Canberra/Melbourne Australia
Posts: 4,159
Guessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant future
Default
Your sample docs are still not consistently showing every edge case but this code works with the latest sample
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
    .Font.Bold = True
    .Text = ""
    .Replacement.Text = "^&zzEndBoldzz"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
    .ClearFormatting
    .Text = "[:;, ^t]{1,5}zzEndBoldzz"
    .Replacement.Text = "zzEndBoldzz"
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    
    .Text = "zzEndBoldzz[:;, ^t]{1,5}"
    .Execute Replace:=wdReplaceAll
    
    .Text = "zzEndBoldzzmeans[:;, ^t]{1,5}"
    .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-Za-z0-9])\)"          'make sure lists with unopened brackets a) get opening bracket (a)
    .Replacement.Text = "^13(\1)"
    .Execute Replace:=wdReplaceAll
    
    .Text = "^13([A-Za-z0-9])."          '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
    
    .ClearFormatting
    .Text = "zzEndBoldzz^13^t"
    .Replacement.Text = "^t"
    .Execute Replace:=wdReplaceAll
    
    .Text = "zzEndBoldzz"
    .Replacement.Text = "^t"
    .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
__________________
Andrew Lockton
Chrysalis Design, Melbourne Australia
Reply With Quote
  #5  
Old 07-04-2021, 04:33 AM
Shelley Lou Shelley Lou is offline VBA to only remove word at beginning and not additional instances within the same paragraph Windows 10 VBA to only remove word at beginning and not additional instances within the same paragraph Office 2016
Expert
VBA to only remove word at beginning and not additional instances within the same paragraph 		 
Join Date: Dec 2020
Posts: 259
Shelley Lou is on a distinguished road
Default VBA to only remove word at beginning and not additional instances within the same paragraph
Hi Andrew, wow many thanks for this code, I have tested it on several documents and I've only come across a couple of issues namely if a space after the word 'means' is bold the macro doesn't recognise it and puts all the text in column 1 and secondly, if the bold definition wording is in capitals e.g VAT it inserts the unique code next to VAT. I will have a go at sorting these myself, see what I can come up with. Again though thank you so much for helping me I really appreciate it.
Reply With Quote
  #6  
Old 07-04-2021, 05:51 AM
Shelley Lou Shelley Lou is offline VBA to only remove word at beginning and not additional instances within the same paragraph Windows 10 VBA to only remove word at beginning and not additional instances within the same paragraph Office 2016
Expert
VBA to only remove word at beginning and not additional instances within the same paragraph 		 
Join Date: Dec 2020
Posts: 259
Shelley Lou is on a distinguished road
Default VBA to only remove word at beginning and not additional instances within the same paragraph
Hi Andrew, I have fixed both issues as follows. Thanks again for your help.

Code:
Sub DPU_DefinitionTabulator()
  Dim aRng As Range, aTbl As Table, aPara As Paragraph, aCell As Cell, oBorder As Border
    Application.ScreenUpdating = False
  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 = "means "
    .Replacement.Text = "means "
    .Replacement.Font.Bold = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Font.Bold = True
    .Text = ""
    .Replacement.Text = "^&zzEndBoldzz" 'Inserts a unique tag for bold words
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
    
    .ClearFormatting
    .Text = "[:;, ^t]{1,5}zzEndBoldzz" 'inserts unique tag for punctuation before 'means'
    .Replacement.Text = "zzEndBoldzz"
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll

    .Text = "zzEndBoldzz[:;, ^t]{1,5}" 'inserts unique tag for punctuation after 'means'
    .Execute Replace:=wdReplaceAll
    
    .Text = "zzEndBoldzzmeans[:;, ^t]{1,5}" 'Additional word 'means' in para not removed
    .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-Za-z0-9])\)"          'make sure lists with a) get opening bracket (a)
    .Replacement.Text = "^13(\1)"
    .Execute Replace:=wdReplaceAll
    
    .Text = "^13([A-Za-z0-9])."          'make sure lists with a. get brackets (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
    
    .ClearFormatting
    .Text = "zzEndBoldzz^13^t" 'Removes unique tab and inserts tab
    .Replacement.Text = "^t"
    .Execute Replace:=wdReplaceAll
    
    .Text = "zzEndBoldzz"
    .Replacement.Text = "^t" 'Removes unique tab and inserts tab
    .Execute Replace:=wdReplaceAll
    
    .Text = "ZZENDBOLDZZ^13^t" 'Removes uppercase unique tab and inserts tab
    .Replacement.Text = "^t"
    .Execute Replace:=wdReplaceAll
    
    .Text = "ZZENDBOLDZZ" 'Removes unique tab and inserts tab
    .Replacement.Text = "^t"
    .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 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
  Application.ScreenUpdating = True
End Sub
Reply With Quote
  #7  
Old 07-04-2021, 03:46 PM
Guessed's Avatar
Guessed Guessed is offline VBA to only remove word at beginning and not additional instances within the same paragraph Windows 10 VBA to only remove word at beginning and not additional instances within the same paragraph Office 2016
Expert
  
Join Date: Mar 2010
Location: Canberra/Melbourne Australia
Posts: 4,159
Guessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant future
Default
Good to hear you could tweak it to deal with your additional instances not shown in the samples you provided.

Although it doesn't affect the running of the macro, it is worthwhile cleaning up the comments in the code. The comments on this chunk for instance is not correct at all.
Code:
    .ClearFormatting
    .Text = "[:;, ^t]{1,5}zzEndBoldzz" 'inserts unique tag for punctuation before 'means'
    .Replacement.Text = "zzEndBoldzz"
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll

    .Text = "zzEndBoldzz[:;, ^t]{1,5}" 'inserts unique tag for punctuation after 'means'
    .Execute Replace:=wdReplaceAll
    
    .Text = "zzEndBoldzzmeans[:;, ^t]{1,5}" 'Additional word 'means' in para not removed
    .Execute Replace:=wdReplaceAll
1. is removing up to 5 instances of spaces or punctuation characters in front of zzEndBoldzz
2. is removing up to 5 instances of spaces or punctuation characters following zzEndBoldzz
3. is removing 'means and trailing punctuation' if it appears immediately after zzEndBoldzz
__________________
Andrew Lockton
Chrysalis Design, Melbourne Australia
Reply With Quote
  #8  
Old 07-05-2021, 12:30 AM
Shelley Lou Shelley Lou is offline VBA to only remove word at beginning and not additional instances within the same paragraph Windows 10 VBA to only remove word at beginning and not additional instances within the same paragraph Office 2016
Expert
VBA to only remove word at beginning and not additional instances within the same paragraph 		 
Join Date: Dec 2020
Posts: 259
Shelley Lou is on a distinguished road
Default VBA to only remove word at beginning and not additional instances within the same paragraph
Hi Andrew, thank you for the pointers regarding the comments as these are quite important so I always know what each step does. I worked on a few more tweaks yesterday as I found if any punctuation such as periods or semi-colons were bold, the macro inserted the unique code after them so I inserted at the beginning to remove bold format from these. I also updated the zzEndBoldzz to ZZENDBOLDZZ which then covers all bases for both title case and uppercase definitions which seem to work well. Thank you for being very patient with me.

Code:
Sub DPU_DefinitionTabulator()
  Dim aRng As Range, aTbl As Table, aPara As Paragraph, aCell As Cell, oBorder As Border
    Application.ScreenUpdating = False
  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 = "means "
    .Replacement.Text = "means "
    .Replacement.Font.Bold = False
    .Execute Replace:=wdReplaceAll
    
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ";" 'Remove bold format from semi-colons
    .Font.Bold = True
    .Replacement.Text = ";"
    .Replacement.Font.Bold = False
    .Execute Replace:=wdReplaceAll
    .Text = "." 'Remove bold format from period
    .Font.Bold = True
    .Replacement.Text = "."
    .Replacement.Font.Bold = False
    .Execute Replace:=wdReplaceAll
    
    .ClearFormatting
    .Replacement.ClearFormatting
    .Font.Bold = True
    .Text = ""
    .Replacement.Text = "^&ZZENDBOLDZZ" 'Inserts a unique tag for bold words
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
    
    .ClearFormatting
    .Text = "[:;, ^t]{1,5}ZZENDBOLDZZ" 'Removes upto 5 instances of spaces/punctuation in front of zzEndBoldzz
    .Replacement.Text = "ZZENDBOLDZZ"
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll

    .Text = "ZZENDBOLDZZ[:;, ^t]{1,5}" 'removes upto 5 instances of spaces/punctuation following zzEndBoldzz
    .Execute Replace:=wdReplaceAll
    
    .Text = "ZZENDBOLDZZmeans[:;, ^t]{1,5}" 'removes 'means' & trailing punctuation' if appears immediately after zzEndBoldzz
    .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-Za-z0-9])\)"          'make sure lists with a) get opening bracket (a)
    .Replacement.Text = "^13(\1)"
    .Execute Replace:=wdReplaceAll
    
    .Text = "^13([A-Za-z0-9])."          'make sure lists with a. get brackets (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
    
    .ClearFormatting
    .Text = "ZZENDBOLDZZ^13^t" 'Removes unique tab and inserts tab
    .Replacement.Text = "^t"
    .Execute Replace:=wdReplaceAll
    
    .Text = "ZZENDBOLDZZ"
    .Replacement.Text = "^t" 'Removes unique tab and inserts tab
    .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 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
  Application.ScreenUpdating = True
End Sub
Reply With Quote
Reply

« Previous Thread | Next Thread »


Similar Threads
Thread Thread Starter Forum Replies Last Post
VBA to only remove word at beginning and not additional instances within the same paragraph Replace a character only if it is at the beginning of the paragraph. donpopo Word 2 11-11-2018 11:32 PM
VBA to only remove word at beginning and not additional instances within the same paragraph Word macro to insert text at the beginning of paragraph but skip tables ashalles135 Word VBA 5 09-26-2018 09:49 AM
VBA to only remove word at beginning and not additional instances within the same paragraph Space tab at the beginning of each paragraph in a chapter village Word 3 07-20-2018 01:48 AM
VBA to only remove word at beginning and not additional instances within the same paragraph word macro To insert text at the beginning and at end of paragraph ArieH Word VBA 20 09-10-2017 04:23 PM
VBA to only remove word at beginning and not additional instances within the same paragraph remove row from dataset for additional calculations canajun Excel 1 01-06-2015 06:38 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 11:28 PM.

Contact Us - Privacy Statement - Top

Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2025, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2025 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft