![]() |
|
#1
|
|||
|
|||
![]() Hi guys, this may well be a long shot but I am looking to create a macro that deletes any additional tabs after the initial first tab. I've created a macro that will highlight any tabs in a document but wondered if it was possible. The tab after "Plan" needs to remain as a tab but the tabs after "Plan 1" "Plan 2" need to be replaced with a space. Is there a way of telling a macro to only keep the first tab and replace any others with spaces? tabs.JPG |
#2
|
||||
|
||||
![]()
You don't need a macro for this - it can all be done with a wildcard Find/Replace, where:
Find = (["“]Plan [0-9]@["”])^t Replace = \1^32
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
![]()
Paul's method will work and be very fast for the specific example you gave. If you want a macro that simply deletes all but the first tab in each paragraph of text, you could use:
Code:
Sub ScratchMacro() 'A basic Word macro coded by Greg Maxey Dim oPar As Paragraph Dim oRng As Range Dim lngIndex As Long For Each oPar In ActiveDocument.Range.Paragraphs lngIndex = 0 Set oRng = oPar.Range With oRng.Find .Text = Chr(9) While .Execute oRng.Select lngIndex = lngIndex + 1 If lngIndex > 1 Then oRng.Text = " " oRng.Collapse wdCollapseEnd End If Wend End With Next oPar lbl_Exit: Exit Sub End Sub |
#4
|
||||
|
||||
![]() Quote:
Code:
Sub Demo() Application.ScreenUpdating = False With ActiveDocument.Range .InsertBefore vbCr With .Find .ClearFormatting .Replacement.ClearFormatting .Text = "(^13[!^13]@^t[!^13]@)^t" .Replacement.Text = "\1 " .Forward = True .Wrap = wdFindContinue .MatchWildcards = True End With Do While .Find.Execute = True .Find.Execute Replace:=wdReplaceAll Loop .Characters.First.Text = vbNullString End With Application.ScreenUpdating = True End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
![]()
Hi Macropod, I have inserted your macro into my macro but for some reason when running the code Word just freezes/crashes and I have go to Task Manager and End Task each time, do you know what this might be? I have attached a test document I've been running the code on if that helps.
Attachment 15947 Code:
Sub DPU_convertdefinitions() Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting ActiveDocument.Range.ListFormat.ConvertNumbersToText Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .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 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 .InsertBefore vbCr With .Find .ClearFormatting .Replacement.ClearFormatting .Text = "(^13[!^13]@^t[!^13]@)^t" .Replacement.Text = "\1 " .Forward = True .Wrap = wdFindContinue .MatchWildcards = True End With Do While .Find.Execute = True .Find.Execute Replace:=wdReplaceAll Loop .Characters.First.Text = vbNullString 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 Last edited by Shelley Lou; 12-17-2020 at 01:39 PM. |
#6
|
|||
|
|||
![]()
I have updated the code to now convert the text to a 2 column table, I have set the width of both columns, removed the borders of the table to No Border and have justified the text. How can I set Column 1 to be left aligned but keep Column 2 as justified. I also need to include font as Arial 10 with line spacing of At Least 15pt. Can anyone help at all?
Code:
Sub DPU_converttexttotable() Selection.WholeStory 'convert text to table 2 columns' 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 'width of column 1 to be 2.7 inches' Selection.Columns(1).PreferredWidth = InchesToPoints(2.7) Selection.Columns.PreferredWidthType = wdPreferredWidthPoints 'width of column 2 to be 3.63 inches' Selection.Columns(2).PreferredWidth = InchesToPoints(3.63) 'alignment of column 2 is Justify' Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend 'remove borders of entire table' 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 |
#7
|
|||
|
|||
![]()
Hi Macropod, I have inserted your macro into my macro but for some reason when running the code Word just freezes/crashes and I have go to Task Manager and End Task each time, do you know what this might be? I have attached a test document I've been running the code on if that helps.
definitions test 3.docx Code:
Sub DPU_convertdefinitions() Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting ActiveDocument.Range.ListFormat.ConvertNumbersToText Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .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 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 .InsertBefore vbCr With .Find .ClearFormatting .Replacement.ClearFormatting .Text = "(^13[!^13]@^t[!^13]@)^t" .Replacement.Text = "\1 " .Forward = True .Wrap = wdFindContinue .MatchWildcards = True End With Do While .Find.Execute = True .Find.Execute Replace:=wdReplaceAll Loop .Characters.First.Text = vbNullString 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 |
#8
|
|||
|
|||
![]() Quote:
definitions test 3.docx |
#9
|
||||
|
||||
![]()
The problem appears to be related to the presence of fields in your content. Try:
Code:
Sub Demo() 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 End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#10
|
|||
|
|||
![]()
Hi Macropod, that seems to have done the trick - with regard to fields, yes there are cross reference fields within some of the definitions. I've just spotted another issue which I wondered if you could help with - in the attached image below - sometimes there will be text under the defined word/text which do not have (a), (b) as sub paras. Is there a way to tell the code to insert a tab before these to be able to then convert into a 2 column table?
insert tab.JPG Code:
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 |
#11
|
|||
|
|||
![]()
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? |
#12
|
|||
|
|||
![]() Quote:
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 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 2. after macro 1 has run - definitions.docx 3. after macro 2 has run - definitions.docx |
#13
|
|||
|
|||
![]()
Shelly,
Just based on the samples you sent there seemed to be a bit of extraneous processes in your code. Each of us has there own style and Paul's is different than mine. You are not going to find a better Find and Replace guy than Paul. He just does things differently. I always try to avoid the selection object. Here is how I would probably process your document (but I don't see the reason for highlighting the tabs): Code:
Option Explicit Sub DPU_convertdefinitions() Dim oRng As Range 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 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 With oRng.Find .Text = "^p(" .Replacement.Text = "^p^t(" .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 Set oRng = ActiveDocument.Range 'Clears colons or spaces after tabs. With oRng.Find .Text = "^t[: ]{1,}" .Replacement.Text = "^t" .MatchWildcards = True .Execute Replace:=wdReplaceAll End With 'Replace periods with semi colons at end of each definition Set oRng = ActiveDocument.Range With oRng.Find .Text = ".^p" .Replacement.Text = "^p" .Execute Replace:=wdReplaceAll End With 'Highligt tabs Set oRng = ActiveDocument.Range 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 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 DPU_Tables Application.ScreenUpdating = True lbl_Exit: Set oRng = Nothing Exit Sub End Sub 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 Sub DPU_Tables() Dim oRng As Range Set oRng = ActiveDocument.Range With oRng .Font.Name = "Arial" .Font.Size = 10 With .ParagraphFormat .SpaceBefore = 0 .SpaceBeforeAuto = False .SpaceAfter = 9 .SpaceAfterAuto = False .LineSpacingRule = wdLineSpaceAtLeast .LineSpacing = 15 .LineUnitBefore = 0 .LineUnitAfter = 0 .Alignment = wdAlignParagraphJustify End With .ConvertToTable Separator:=wdSeparateByTabs, NumColumns:=2, _ NumRows:=8, AutoFitBehavior:=wdAutoFitFixed With .Tables(1) .Style = "Table Grid" .ApplyStyleHeadingRows = True .ApplyStyleLastRow = False .ApplyStyleFirstColumn = True .ApplyStyleLastColumn = False .Columns.PreferredWidthType = wdPreferredWidthPoints .Columns(1).PreferredWidth = InchesToPoints(2.7) .Columns.PreferredWidthType = wdPreferredWidthPoints .Columns(2).PreferredWidth = InchesToPoints(3.63) End With End With lbl_Exit: Set oRng = Nothing Exit Sub End Sub |
#14
|
|||
|
|||
![]()
Hi Greg
Thank you so much for looking at this code for me, it is very much appreciated. I've just come across a small issue in that if the paragraph mark at the end of each definition is bold the code thinks this is a new definition and inserts quote marks. I'm trying to add somewhere in the code for formatting to be cleared from paragraph marks. Best wishes, Shelley unbold para marks.JPG |
#15
|
|||
|
|||
![]()
Hi Greg, with a bit of playing around I've managed to sort the bold para marks issue with the following code which seems to work slotted in just below ResetFRParameters. Thanks so much for your help on this.
Code:
With oRng.Find 'remove bold from para marks' .Text = "^p" .Replacement.Text = "^p" .Replacement.Font.Bold = False .Execute Replace:=wdReplaceAll End With |
![]() |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
![]() |
LuisXVI | Word VBA | 4 | 11-12-2018 03:12 PM |
![]() |
staicumihai | Word VBA | 4 | 11-07-2018 01:14 AM |
![]() |
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 |
![]() |
AlexanderJohnWilley | Word VBA | 7 | 11-08-2012 10:15 AM |