Solved

Need Word Macro to Find and Change Entire Line to Style

Posted on 2016-07-21
6
53 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:Alex972
  • 4
6 Comments
 
LVL 31

Accepted Solution

by:
Helen_Feddema earned 500 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 31

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
NAS Cloud Backup Strategies

This article explains backup scenarios when using network storage. We review the so-called “3-2-1 strategy” and summarize the methods you can use to send NAS data to the cloud

 
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:Alex972
ID: 41723940
Very good. Thanks
0

Featured Post

Master Your Team's Linux and Cloud Stack

Come see why top tech companies like Mailchimp and Media Temple use Linux Academy to build their employee training programs.

Question has a verified solution.

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

This article describes how to use the Send to Mail Recipient command. The instructions apply generally to Office 2007 and later versions, but Microsoft® Word 2013 was used for the specific steps and figures.  What is Send to Mail Recipient? Send…
Using Word 2013, I was experiencing some incredible lag when typing.  Here's what worked for me....
This video shows the viewer how to set up and create Footnotes in their document. Click on the References tab: Select "Insert Footnote": Type in desired text:
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …

825 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