First of all this is the first time I am creating a macro using VBA code. With some bits and pieces i found on the internet I tried to create the following. I am not a developer at all, I just have some basic knowledge from school. So my apologies if this is poor coding.

I am creating a macro in word which highlights text from a paragraph heading until the next heading with the same style. This is done based on a list of headings I import from Excel. You can find the code I have created below. The result with few input is perfect, so that's a good thing! The execution is very slow though (3 to 4h), which is probably related to the many selects I use. (I read only this is very often the cause of slow macros)

I tried to expand my Range with one line at the time using " Range.Expand Unit:=wdLine " but it's giving me errors every time. Therefore I use the moveDown selection method now which is doing the trick. Does anyone know a way I could use ranges here to speed up the process?

Many thanks in advance.

 Sub Highlight_WordN()
Dim par As Paragraph
Dim par2 As Paragraph
Dim doc As Document
Dim oRng As Range
Dim Sty As Style
Dim intCurrentLine As Integer
Dim strFindArray() As String
Dim strIn As String
Dim strWorkBookName As String
Dim strNumberCells As String
Dim MessageFound As String
Dim MessageNotFound As String
Dim Flag As Boolean
Dim IsHeading As Boolean
Dim IsNothing As Boolean
'*****Set parameters for performance***** Word.Application.ScreenUpdating = False Word.Application.Options.CheckGrammarAsYouType = False Word.Application.Options.CheckGrammarWithSpelling = False Word.Application.Options.CheckSpellingAsYouType = False Word.Application.Options.AnimateScreenMovements = False Word.Application.Options.BackgroundSave = False Word.Application.Options.CheckHangulEndings = False Word.Application.Options.DisableFeaturesbyDefault = True
'*****Load data from excel*****
'List of headers to delete Dim xlApp As Object Dim xlBook As Object strWorkBookName = "C:\Users\driesenn\OneDrive\OMAR\UPDATE\ToDelete.xlsx" On Error Resume Next Set xlApp = GetObject(, "Excel.Application") If Err Then Set xlApp = CreateObject("Excel.Application") End If On Error GoTo 0 Set xlBook = xlApp.Workbooks.Open(FileName:=strWorkBookName) xlApp.Visible = False ArrayLen = 0 ArrayLen = xlApp.ActiveSheet.Range("B1") strNumberCells = "A1:A" & ArrayLen strArray = xlApp.Transpose(xlApp.ActiveSheet.Range(strNumberCells)) ArrayLen = 0 ArrayLen = UBound(strArray) - LBound(strArray) + 1 Set xlBook = Nothing xlApp.Quit Set xlApp = Nothing
'*****Start evaluation process for headers*****
ArrayLen = UBound(strArray) - LBound(strArray) + 1
'Loop over all headers in the array
For i = 1 To ArrayLen strFind = strArray(i) 'Evaluate every paragraph heading For Each par In ActiveDocument.Paragraphs If par.Style Like "Heading*" Then Set Sty = par.Style 'Search for the header number in the heading If InStr(par.Range.Text, strFind) = 1 Then Set oRng = par.Range oRng.Select intCurrentLine = oRng.Information(wdFirstCharacterLineNumber) Set oRng = Selection.Next(Unit:=wdLine, Count:=1) 'If the next line is not a header --> go on IsHeading = False If oRng.Style Like "Heading*" Then IsHeading = True End If 'Keep looping until the next heading of this type is found Do While oRng.Style > Sty Or IsHeading = False Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend Set oRng = Selection.Next(Unit:=wdLine, Count:=1) If oRng Is Nothing Then Exit Do End If 'If the next line is not a header --> go on IsHeading = False If oRng.Style Like "Heading*" Then IsHeading = True End If Loop Selection.Start = par.Range.Start 'If we are not at the end of the document selection ends with last line of current range. If oRng Is Nothing Then Else Selection.End = oRng.Start End If 'Set highlight Selection.Range.HighlightColorIndex = wdYellow End If End If Next
Next
End Sub

3

2 Answers

Firstly, it will assist you to become familiar with using help. Place your cursor in the keyword that you need help with and press F1. Had you done so for the Expand method you would have landed here. You will find the valid parameters for Unit are listed.

Secondly, paragraph styles are applied to paragraphs not lines. So you need to check the style of each paragraph and expand the range by one paragraph at a time. This will enable you to avoid selecting anything.

4

The following code shows a much easier way of highlighting the ranges associated with different heading levels, using Word's built-in '\HeadingLevel' bookmark:

Sub Demo()
Dim h As Long, c As Long, Rng As Range
For h = 1 To 9 With ActiveDocument.Range With .Find .ClearFormatting .Replacement.ClearFormatting .Text = "" .Style = "Heading " & h .Replacement.Text = "" .Format = True .Forward = True .Execute End With Do While .Find.Found Set Rng = .Paragraphs(1).Range Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel") Select Case h Case 1 To 4: c = h + 1 Case 5: c = h + 2 Case 6 To 8: c = h + 4 Case 9: c = h + 5 Case Else: c = 0 End Select Rng.HighlightColorIndex = c .Collapse wdCollapseEnd If .Information(wdWithInTable) = True Then If .End = .Cells(1).Range.End - 1 Then .End = .Cells(1).Range.End .Collapse wdCollapseEnd If .Information(wdAtEndOfRowMarker) = True Then .End = .End + 1 End If End If If .End = ActiveDocument.Range.End Then Exit Do .Collapse wdCollapseEnd .Find.Execute Loop End With
Next
End Sub

Of course, as the above code loops through all 9 heading levels, what ends up with a given highlight depends on how many other lower-level headings (higher numbers) are nested within a given higher-level heading (lower numbers).

Your Answer

Sign up or log in

Sign up using Google Sign up using Facebook Sign up using Email and Password Submit

Post as a guest

Post Your Answer Discard

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.