?
Solved

Need Word Macro to Find and Change Entire Line to Style

Posted on 2016-07-21
6
Medium Priority
?
75 Views
Last Modified: 2016-07-21
Need a macro that would find Sub in the below example, highlight the rest of line (it can include the word Sub) and then
change the style to Heading 2.  It need it to run until it reaches the end of the document.

Sub InsertPics()
 Dim fd As FileDialog
 Dim rng As Range
 Dim ilsh As InlineShape
0
Comment
Question by:Alex Campbell
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 4
6 Comments
 
LVL 31

Accepted Solution

by:
Helen Feddema earned 2000 total points
ID: 41723826
I have a Word macro that does this (and a lot more).  I use it to format code for readability.  I just copy a procedure, paste it into a document made from the template, and it applies formatting to the entire procedure.  Here is the code, which you could paste into a new template and modify as needed.

Sub Test()

   Debug.Print "Docs path: " & Options.DefaultFilePath(wdDocumentsPath)
   Debug.Print "Current path: " & Options.DefaultFilePath(wdCurrentFolderPath)
   Debug.Print "Template path: " & Options.DefaultFilePath(wdUserTemplatePath)
   

End Sub

Sub FormatCode()
'Created 03-26-1997 by Helen Feddema
'Last modified 11-10-2003

   Dim strTitle As String
   Dim strFindText As String
   Dim strReplaceText As String
   Dim rngSave As Range
   Dim strApostrophe As String
   Dim lngEnd As Long
   Dim rngEnd As Range
   Dim varPosition As Variant
   
   With Selection
      .WholeStory
      .Style = ActiveDocument.Styles("Code")
      .HomeKey Unit:=wdStory
      .Find.ClearFormatting
      .Find.Replacement.ClearFormatting
   End With
   
   'Insert page breaks between procedures
   strFindText = "^pSub"
   strReplaceText = "^p^mSub"
   
   Selection.Find.ClearFormatting
   Selection.Find.Replacement.ClearFormatting
   With Selection.Find
      .Text = strFindText
      .Replacement.Text = strReplaceText
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   
   strFindText = strFindText
   strReplaceText = "^p^mPrivate Sub"
   
   Selection.Find.ClearFormatting
   Selection.Find.Replacement.ClearFormatting
   With Selection.Find
      .Text = "^pPrivate Sub"
      .Replacement.Text = strReplaceText
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   
   strFindText = "^pFunction"
   strReplaceText = "^p^mFunction"
   
   Selection.Find.ClearFormatting
   Selection.Find.Replacement.ClearFormatting
   With Selection.Find
      .Text = strFindText
      .Replacement.Text = strReplaceText
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   
   strFindText = "^pProperty Get"
   strReplaceText = "^p^mProperty Get"
   
   Selection.Find.ClearFormatting
   Selection.Find.Replacement.ClearFormatting
   With Selection.Find
      .Text = strFindText
      .Replacement.Text = strReplaceText
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   
   strFindText = "^pProperty Let"
   strReplaceText = "^p^mProperty Let"
   
   Selection.Find.ClearFormatting
   Selection.Find.Replacement.ClearFormatting
   With Selection.Find
      .Text = strFindText
      .Replacement.Text = strReplaceText
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   
   strFindText = "^pProperty Set"
   strReplaceText = "^p^mProperty Set"
   
   Selection.Find.ClearFormatting
   Selection.Find.Replacement.ClearFormatting
   With Selection.Find
      .Text = strFindText
      .Replacement.Text = strReplaceText
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   
   strFindText = "^pPublic Function"
   strReplaceText = "^p^mPublic Function"
   
   Selection.Find.ClearFormatting
   Selection.Find.Replacement.ClearFormatting
   With Selection.Find
      .Text = strFindText
      .Replacement.Text = strReplaceText
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   
   strFindText = "^pPublic Sub"
   strReplaceText = "^p^mPublic Sub"
   
   Selection.Find.ClearFormatting
   Selection.Find.Replacement.ClearFormatting
   With Selection.Find
      .Text = strFindText
      .Replacement.Text = strReplaceText
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   
   strFindText = "^pPrivate Function"
   strReplaceText = "^p^mPrivate Function"
   
   Selection.Find.ClearFormatting
   Selection.Find.Replacement.ClearFormatting
   With Selection.Find
      .Text = strFindText
      .Replacement.Text = strReplaceText
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   
   'Format procedure headings with Heading 2 style
   Set rngSave = Selection.Range
   Selection.HomeKey Unit:=wdStory
   
   strFindText = "^p^mSub"
   
   With Selection.Find
      .ClearFormatting
      .Execute findtext:=strFindText
      While .Found = True
         Selection.EndKey Unit:=wdLine, Extend:=wdExtend
         Selection.Style = ActiveDocument.Styles("Heading 2")
         Selection.MoveRight
         .Execute
      Wend
      rngSave.Select
   End With
   
   strFindText = "^p^mPrivate Sub"
   
   With Selection.Find
      .ClearFormatting
      .Execute findtext:=strFindText
      While .Found = True
         Selection.EndKey Unit:=wdLine, Extend:=wdExtend
         Selection.Style = ActiveDocument.Styles("Heading 2")
         Selection.MoveRight
         .Execute
      Wend
      rngSave.Select
   End With
   
   strFindText = "^p^mFunction"
   
   With Selection.Find
      .ClearFormatting
      .Execute findtext:=strFindText
      While .Found = True
         Selection.EndKey Unit:=wdLine, Extend:=wdExtend
         Selection.Style = ActiveDocument.Styles("Heading 2")
         Selection.MoveRight
         .Execute
      Wend
      rngSave.Select
   End With
   
   strFindText = "^p^mProperty"
   
   With Selection.Find
      .ClearFormatting
      .Execute findtext:=strFindText
      While .Found = True
         Selection.EndKey Unit:=wdLine, Extend:=wdExtend
         Selection.Style = ActiveDocument.Styles("Heading 2")
         Selection.MoveRight
         .Execute
      Wend
      rngSave.Select
   End With
   
   strFindText = "^p^mPublic Function"
   
   With Selection.Find
      .ClearFormatting
      .Execute findtext:=strFindText
      While .Found = True
         Selection.EndKey Unit:=wdLine, Extend:=wdExtend
         Selection.Style = ActiveDocument.Styles("Heading 2")
         Selection.MoveRight
         .Execute
      Wend
      rngSave.Select
   End With
   
   strFindText = "^p^mPublic Sub"
   
   With Selection.Find
      .ClearFormatting
      .Execute findtext:=strFindText
      While .Found = True
         Selection.EndKey Unit:=wdLine, Extend:=wdExtend
         Selection.Style = ActiveDocument.Styles("Heading 2")
         Selection.MoveRight
         .Execute
      Wend
      rngSave.Select
   End With
   
   strFindText = "^p^mPrivate Function"
   
   With Selection.Find
      .ClearFormatting
      .Execute findtext:=strFindText
      While .Found = True
         Selection.EndKey Unit:=wdLine, Extend:=wdExtend
         Selection.Style = ActiveDocument.Styles("Heading 2")
         Selection.MoveRight
         .Execute
      Wend
      rngSave.Select
   End With
   
   'Apply Label style to labels
   strFindText = ":^p"
   
   With Selection.Find
      .ClearFormatting
      .Execute findtext:=strFindText
      While .Found = True
         Selection.HomeKey Unit:=wdLine
         Selection.EndKey Unit:=wdLine, Extend:=wdExtend
         Selection.Style = ActiveDocument.Styles("Label")
         Selection.MoveRight Unit:=wdCharacter, Count:=1
         .Execute
      Wend
      rngSave.Select
   End With
   
   'Apply Comment style to comments
   strFindText = Chr$(39)
      With Selection.Find
         .ClearFormatting
         .Execute findtext:=strFindText
         While .Found = True
            'Test whether apostrophe is not at beginning of line
            varPosition = _
               Selection.Information(wdHorizontalPositionRelativeToTextBoundary)
            'Debug.Print "Position of apostrophe: " & varPosition
            If varPosition < 140 Then
               Selection.EndKey Unit:=wdLine, Extend:=wdExtend
               Selection.Style = ActiveDocument.Styles("Comment")
               Selection.MoveRight Unit:=wdCharacter, Count:=1
               .Execute
            Else
               Selection.MoveRight Unit:=wdCharacter, Count:=1
               .Execute
            End If
         Wend
         rngSave.Select
      End With
   
   'Format document heading with Heading 2 style
   Selection.EndKey Unit:=wdLine, Extend:=wdExtend
   Selection.Style = ActiveDocument.Styles("Heading 2")
   Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
   strTitle = Selection
   
   If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
      ActiveWindow.Panes(2).Close
   End If
   If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
      ActivePane.View.Type = wdOutlineView Or ActiveWindow.ActivePane.View.Type _
       = wdMasterView Then
      ActiveWindow.ActivePane.View.Type = wdPageView
   End If
   
   'Suggest document title, and save user's choice to Title field
   If ActiveDocument.BuiltInDocumentProperties("Title") = "None" Then
      If Left(strTitle, 23) <> "Option Compare Database" Then
         ActiveDocument.BuiltInDocumentProperties("Title") = strTitle
      Else
         strTitle = InputBox(prompt:="Please enter the document name", Title:="Document Name", Default:="___ Form Module")
         ActiveDocument.BuiltInDocumentProperties("Title") = strTitle
         Selection.HomeKey Unit:=wdLine
         Selection.MoveDown Unit:=wdLine, Count:=3, Extend:=wdExtend
         Selection.Delete Unit:=wdCharacter, Count:=1
         Selection.TypeText Text:=strTitle
         Selection.TypeParagraph
      End If
   End If
   
End Sub

Open in new window


I am also attaching the template, in case you want to try it.  To use it, first copy the code to the clipboard, then make a new document from template; it will ask if you want to import the code from the clipboard -- say Yes.  Then run the FormatCode macro to do the formatting.  (I put it on the Quick Access Toolbar.)
0
 
LVL 31

Expert Comment

by:Helen Feddema
ID: 41723828
The .dotm extension wasn't accepted; I tried using a zip file with it inside, but that was rejected too.  If you want the template emailed to you, send me a message with your email.
0
 
LVL 33

Expert Comment

by:Paul Sauvé
ID: 41723898
you can use ee-stuff.com to upload blocked files using your E-E creds to login: https://www.ee-stuff.com/

To upload:
select Experts Area ―> Upload a new file ―> Question or Article URL ―> upload file

To download:
select Experts Area ―> Find files for a question ―> Question URL ―> download file
0
Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

 
LVL 31

Expert Comment

by:Helen Feddema
ID: 41723915
I uploaded the template to ee-stuff.
0
 
LVL 31

Expert Comment

by:Helen Feddema
ID: 41723930
Here is a screen shot of a page of formatted code:

Formatted code
0
 
LVL 1

Author Closing Comment

by:Alex Campbell
ID: 41723940
Very good. Thanks
0

Featured Post

Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Preface: When I started this series, I used the term CommandBars because that is the Office Object class that it discusses. Unfortunately, when Microsoft introduced Office 2007, they replaced the standard Commandbar menus with "The Ribbon" and rem…
Microsoft Word is a program we have all encountered at some point, but very few of us have dug deep into its full scope of features, let alone customized it to suit our needs. Luckily making the ribbon (aka toolbar, first introduced in Word 2007) wo…
This video walks the viewer through the process of creating an MLA formatted document, as well as a bibliography with citations.
Office 365 is currently available in five editions. Three of them are for business use: Office 365 Business Essentials, Office 365 Business, and Office 365 Business Premium. Two of them are for home/personal use: Office 365 Home and Office 365 Perso…
Suggested Courses

800 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question