Microsoft Office Forums - View Single Post

gmaxey · 12-18-2020, 11:06 AM

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