![]() |
|
#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
|
|||
|
|||
|
Shelly,
Adding this as one of the first process (before adding the quotes) should work: ResetFRParameters Set oRng = ActiveDocument.Range With oRng.Find .Text = "^p" While .Execute oRng.Font.Reset Wend End With |
|
| Thread Tools | |
| Display Modes | |
|
|
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 |