Quote:
Originally Posted by gmaxey
Shelly,
Paul is semi-retired from this forum and it is anyone's guess when or if he will pop in again. What is your current code (all of it) and what specific issue remains?
|
Hi Greg, I didn't realise that. Basically my job is to convert documents to house style and I've been working on a macro to convert all of the definitions in one go as it can be a time consuming job. The first macro (DPU_convertdefinitions) does all the formatting and then macro 2 (DPU_Tables) converts to a 2 column table with no border. It all seems to work fine except where there are normal text below a definition e.g. at " Balancing Payment" a tab needs to insert before the text - is this possible? I have attached 3 documents, no. 1 is the text before the macros are run; no. 2 is when the first macro is run and no. 3 is when the tables macro has run. I did also wonder if the macros could be tidied up as they do seem a bit lengthy/untidy. Also it would be great if macro 2 can run straight after macro 1? Edit: forgot to mention if column 1 of the table could be set to leftalign and column 2 be set to justify? Thank you so much for your help.
Macro 1
Code:
Sub DPU_convertdefinitions()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
'convert numbers to text'
ActiveDocument.Range.ListFormat.ConvertNumbersToText
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
'remove double quotes'
.Text = """"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'replace tab with space'
With Selection.Find
.Text = "^t"
.Replacement.Text = " "
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
'bold quotes'
Selection.Find.Font.Bold = True
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "<*>"
.Replacement.Text = "^034^&^034^t"
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'tab after quote replace with space'
With Selection.Find
.Text = "^034^t ^034"
.Replacement.Text = "^032"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'remove space after tab'
With Selection.Find
.Text = "^t "
.Replacement.Text = "^t"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^p("
.Replacement.Text = "^p^t("
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'remove the words means from each definition and insert a tab'
With Selection.Find
.Text = "^tmeans"
.Replacement.Text = "^t"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'remove colon after tab'
With Selection.Find
.Text = "^t:"
.Replacement.Text = "^t"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'remove tab and quotes before hyphen'
With Selection.Find
.Text = "^034^t^045^034"
.Replacement.Text = "-"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'remove quote and tab before left bracket'
With Selection.Find
.Text = "^034^t^040^034"
.Replacement.Text = " ("
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'remove quote tab before right bracket'
With Selection.Find
.Text = "^034^t^041 ^034"
.Replacement.Text = ") "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'remove quote, tab and between ampersand'
With Selection.Find
.Text = "^034^t^038^034"
.Replacement.Text = "&"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'remove comma after tab'
With Selection.Find
.Text = "^t,"
.Replacement.Text = "^t"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'remove space after tab'
With Selection.Find
.Text = "^t "
.Replacement.Text = "^t"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'replace periods with semi colons at end of each definition'
With Selection.Find
.Text = ".^p"
.Replacement.Text = ";^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'find tab and highlight'
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Replacement.Highlight = True
With Selection.Find
.Text = "^t"
.Replacement.Text = "^t"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "^t"
.Forward = True
.Wrap = wdFindStop
End With
Do While .Find.Execute = True
.Start = .Paragraphs(1).Range.Start
If Len(.Text) - Len(Replace(.Text, vbTab, "")) > 1 Then .Characters.Last.Text = " "
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
Selection.Find.Execute Replace:=wdReplaceAll
Dim oRng As Range
Const strText As String = "^13[A-Za-z]"
Set oRng = ActiveDocument.Range
With oRng.Find
Do While .Execute(FindText:=strText, MatchWildcards:=True)
If oRng.Paragraphs(2).Style = "Normal" And _
oRng.Paragraphs(2).Range.Characters(1).Font.Bold = False Then
oRng.Paragraphs(2).Range.InsertBefore vbTab
End If
oRng.Collapse 0
Loop
End With
lbl_Exit:
Set oRng = Nothing
Exit Sub
End Sub
Macro 2
Code:
Sub DPU_Tables()
Selection.WholeStory
Selection.Font.Name = "Arial"
Selection.Font.Size = 10
With Selection.ParagraphFormat
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 9
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceAtLeast
.LineSpacing = 15
.LineUnitBefore = 0
.LineUnitAfter = 0
End With
Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
Selection.ConvertToTable Separator:=wdSeparateByTabs, NumColumns:=2, _
NumRows:=8, AutoFitBehavior:=wdAutoFitFixed
With Selection.Tables(1)
.Style = "Table Grid"
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
End With
Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
Selection.Columns(1).PreferredWidth = InchesToPoints(2.7)
Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
Selection.Columns(2).PreferredWidth = InchesToPoints(3.63)
Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Borders(wdBorderTop).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderRight).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderVertical).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
End Sub
1. before macros are run - definitions.docx
2. after macro 1 has run - definitions.docx
3. after macro 2 has run - definitions.docx