![]() |
|
|
|
#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
|
|
|
|
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 |