Macro to delete tabs in Word

Shelley Lou · #12 12-18-2020, 09:24 AM

Quote:

Originally Posted by gmaxey

Shelly,

Paul is semi-retired from this forum and it is anyone's guess when or if he will pop in again. What is your current code (all of it) and what specific issue remains?

Hi Greg, I didn't realise that. Basically my job is to convert documents to house style and I've been working on a macro to convert all of the definitions in one go as it can be a time consuming job. The first macro (DPU_convertdefinitions) does all the formatting and then macro 2 (DPU_Tables) converts to a 2 column table with no border. It all seems to work fine except where there are normal text below a definition e.g. at " Balancing Payment" a tab needs to insert before the text - is this possible? I have attached 3 documents, no. 1 is the text before the macros are run; no. 2 is when the first macro is run and no. 3 is when the tables macro has run. I did also wonder if the macros could be tidied up as they do seem a bit lengthy/untidy. Also it would be great if macro 2 can run straight after macro 1? Edit: forgot to mention if column 1 of the table could be set to leftalign and column 2 be set to justify? Thank you so much for your help.

Macro 1

Code:

Sub DPU_convertdefinitions()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    'convert numbers to text'
    ActiveDocument.Range.ListFormat.ConvertNumbersToText
     Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
    'remove double quotes'
        .Text = """"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    'replace tab with space'
    With Selection.Find
        .Text = "^t"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    'bold quotes'
  Selection.Find.Font.Bold = True
    Selection.Find.Replacement.ClearFormatting
        With Selection.Find
        .Text = "<*>"
        .Replacement.Text = "^034^&^034^t"
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    'tab after quote replace with space'
    With Selection.Find
        .Text = "^034^t ^034"
        .Replacement.Text = "^032"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    'remove space after tab'
    With Selection.Find
        .Text = "^t "
        .Replacement.Text = "^t"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "^p("
        .Replacement.Text = "^p^t("
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    'remove the words means from each definition and insert a tab'
    With Selection.Find
        .Text = "^tmeans"
        .Replacement.Text = "^t"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
       .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    'remove colon after tab'
    With Selection.Find
        .Text = "^t:"
        .Replacement.Text = "^t"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
       .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    'remove tab and quotes before hyphen'
    With Selection.Find
        .Text = "^034^t^045^034"
        .Replacement.Text = "-"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
       .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
     Selection.Find.Execute Replace:=wdReplaceAll
    'remove quote and tab before left bracket'
    With Selection.Find
        .Text = "^034^t^040^034"
        .Replacement.Text = " ("
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
       .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
     Selection.Find.Execute Replace:=wdReplaceAll
    'remove quote tab before right bracket'
    With Selection.Find
        .Text = "^034^t^041 ^034"
        .Replacement.Text = ") "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
       .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
      Selection.Find.Execute Replace:=wdReplaceAll
    'remove quote, tab and between ampersand'
    With Selection.Find
        .Text = "^034^t^038^034"
        .Replacement.Text = "&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
       .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    'remove comma after tab'
    With Selection.Find
        .Text = "^t,"
        .Replacement.Text = "^t"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
       .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    'remove space after tab'
    With Selection.Find
        .Text = "^t "
        .Replacement.Text = "^t"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    'replace periods with semi colons at end of each definition'
    With Selection.Find
        .Text = ".^p"
      .Replacement.Text = ";^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
     'find tab and highlight'
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.Replacement.Highlight = True
    With Selection.Find
        .Text = "^t"
      .Replacement.Text = "^t"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Application.ScreenUpdating = False
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^t"
    .Forward = True
    .Wrap = wdFindStop
  End With
  Do While .Find.Execute = True
    .Start = .Paragraphs(1).Range.Start
    If Len(.Text) - Len(Replace(.Text, vbTab, "")) > 1 Then .Characters.Last.Text = " "
    .Collapse wdCollapseEnd
  Loop
End With
Application.ScreenUpdating = True
      Selection.Find.Execute Replace:=wdReplaceAll
    Dim oRng As Range
Const strText As String = "^13[A-Za-z]"
    Set oRng = ActiveDocument.Range
    With oRng.Find
        Do While .Execute(FindText:=strText, MatchWildcards:=True)
            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
lbl_Exit:
    Set oRng = Nothing
       Exit Sub
       End Sub

Macro 2

Code:

Sub DPU_Tables()
    Selection.WholeStory
    Selection.Font.Name = "Arial"
    Selection.Font.Size = 10
    With Selection.ParagraphFormat
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 9
        .SpaceAfterAuto = False
        .LineSpacingRule = wdLineSpaceAtLeast
        .LineSpacing = 15
        .LineUnitBefore = 0
        .LineUnitAfter = 0
    End With
    Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
    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
    End With
   Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
    Selection.Columns(1).PreferredWidth = InchesToPoints(2.7)
    Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
    Selection.Columns(2).PreferredWidth = InchesToPoints(3.63)
    Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.Borders(wdBorderTop).LineStyle = wdLineStyleNone
    Selection.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
    Selection.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
    Selection.Borders(wdBorderRight).LineStyle = wdLineStyleNone
    Selection.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
    Selection.Borders(wdBorderVertical).LineStyle = wdLineStyleNone
    Selection.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
    Selection.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
End Sub

1. before macros are run - definitions.docx

2. after macro 1 has run - definitions.docx

3. after macro 2 has run - definitions.docx

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
I need a macro to format images and remove tabs. help	LuisXVI	Word VBA	4	11-12-2018 03:12 PM
Macro to delete pages in Word 2007	staicumihai	Word VBA	4	11-07-2018 01:14 AM
Need Word Macro to Delete Text	rsrasc	Word VBA	4	04-18-2018 11:32 PM
Tabs set along left edge of page; how to delete	ginny	Word	4	03-21-2018 08:07 PM
Word Macro to find and delete rows that contain adjacent cells containing "."	AlexanderJohnWilley	Word VBA	7	11-08-2012 10:15 AM