Seeking Optimization for Word Macro Execution Time

[vincent546]

Hi all! This is my first post in this forum. Nice to meet you all.

I am reaching out to discuss a Word macro I have been utilizing to highlight specific text based on an Excel file. While the macro is functional, I am looking for ways to enhance its performance and reduce the execution time.

Read the code here: https://drive.google.com/file/d/1xqBlXF ... sp=sharing

Applying the macro to a Word document spanning approximately 200 pages takes about one minute to complete the highlighting process. However, I am interested in exploring possibilities to compress this time frame to less than 50 seconds or even faster.

I understand all of you possess extensive expertise in Microsoft Word VBA macros and their optimization. Therefore, I would like to seek guidance in any optimizations that could improve execution.

Your insights and recommendations regarding this matter would be highly appreciated. Your expertise and knowledge will help me achieve the desired improvement in execution time. Please let me know if you require additional information or access to the existing code.

Thank you very much for your attention and support.

[HansV]

Welcome to Eileen's Lounge!

Any connection to yanlok1345?

You set MatchWildcards to True for ALL replacements if at least one row in column C contains T. Is that your intention?

[vincent546]

Welcome to Eileen's Lounge!

Any connection to yanlok1345?

You set MatchWildcards to True for ALL replacements if at least one row in column C contains T. Is that your intention?

I am yanlok's brother. Thank you for your prompt response. Yes. That's my intention.

[HansV]

If nobody else replies, I'll get back to you later.

[vincent546]

If nobody else replies, I'll get back to you later.

Thank you.

[HansV]

I don't see much that can be optimized. Try this version:

Code: Select all

Sub H()

    Dim cellData As Variant
    Dim maxCount, iCount As Long
    Dim excelPath As String
    Dim objExcel As Object
    Dim objWb As Object
    Dim F As Boolean
    Dim VChar As Variant
   
    excelPath = "E:\H.xlsx"

    On Error Resume Next
    Set objExcel = GetObject(Class:="Excel.Application")
    If objExcel Is Nothing Then
        Set objExcel = CreateObject(Class:="Excel.Application")
        F = True
    End If
    Set objWb = objExcel.Workbooks.Open(FileName:=excelPath)
    
    With objWb.Sheets(1)
        maxCount = .Cells(.Rows.Count, 1).End(-4162).Row
        VChar = .Range("A2:A" & maxCount).Value
        If Not .Range("C2:C" & maxCount).Find(What:="T") Is Nothing Then
            Selection.Find.MatchWildcards = True
        End If
    End With
    
    objWb.Close SaveChanges:=False
    If F Then
        objExcel.Quit
    End If
    
    Application.ScreenUpdating = False
    Options.DefaultHighlightColorIndex = wdYellow
    Selection.HomeKey Unit:=wdStory
    
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Highlight = True
        .Replacement.Text = "^&"
        .Wrap = wdFindStop
        For iCount = 1 To maxCount - 1
            If VChar(iCount, 1) <> "" Then
                .Execute FindText:=VChar(iCount - 1), Replace:=wdReplaceAll
            End If
        Next iCount
    End With

    Application.ScreenUpdating = True
End Sub

[vincent546]

I don't see much that can be optimized. Try this version:

Code: Select all

Sub H()

    Dim cellData As Variant
    Dim maxCount, iCount As Long
    Dim excelPath As String
    Dim objExcel As Object
    Dim objWb As Object
    Dim F As Boolean
    Dim VChar As Variant
   
    excelPath = "E:\H.xlsx"

    On Error Resume Next
    Set objExcel = GetObject(Class:="Excel.Application")
    If objExcel Is Nothing Then
        Set objExcel = CreateObject(Class:="Excel.Application")
        F = True
    End If
    Set objWb = objExcel.Workbooks.Open(FileName:=excelPath)
    
    With objWb.Sheets(1)
        maxCount = .Cells(.Rows.Count, 1).End(-4162).Row
        VChar = .Range("A2:A" & maxCount).Value
        If Not .Range("C2:C" & maxCount).Find(What:="T") Is Nothing Then
            Selection.Find.MatchWildcards = True
        End If
    End With
    
    objWb.Close SaveChanges:=False
    If F Then
        objExcel.Quit
    End If
    
    Application.ScreenUpdating = False
    Options.DefaultHighlightColorIndex = wdYellow
    Selection.HomeKey Unit:=wdStory
    
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Highlight = True
        .Replacement.Text = "^&"
        .Wrap = wdFindStop
        For iCount = 1 To maxCount - 1
            If VChar(iCount, 1) <> "" Then
                .Execute FindText:=VChar(iCount - 1), Replace:=wdReplaceAll
            End If
        Next iCount
    End With

    Application.ScreenUpdating = True
End Sub

I appreciate your assistance. Thank you once again for taking the time to help me.

[Jay Freedman]

I'm not sure whether this will make the code any faster, but I don't have the setup to test it...

Manipulating Word's Selection object affects not just the screen display of the document (which is turned off by setting ScreenUpdating = False) but also its internal representation. Instead, you can use a Range object, which is not connected to any display code. It doesn't move the cursor or cause any scrolling, and doesn't trigger any pagination code.

If you want to try it, here's a modified version of Hans' code.

Code: Select all

Sub H()

    Dim cellData As Variant
    Dim maxCount As Long, iCount As Long  ' without As Long, maxCount will be Variant
    Dim oRng As Word.Range  ' Word.Range is not like Excel.Range
    Dim bUseWC As Boolean   ' holder for MatchWildcards value
    Dim excelPath As String
    Dim objExcel As Object
    Dim objWb As Object
    Dim F As Boolean
    Dim VChar As Variant
   
    excelPath = "E:\H.xlsx"

    On Error Resume Next
    Set objExcel = GetObject(Class:="Excel.Application")
    If objExcel Is Nothing Then
        Set objExcel = CreateObject(Class:="Excel.Application")
        F = True
    End If
    Set objWb = objExcel.Workbooks.Open(filename:=excelPath)
    
    With objWb.Sheets(1)
        maxCount = .Cells(.Rows.Count, 1).End(-4162).Row
        VChar = .Range("A2:A" & maxCount).Value
        If Not .Range("C2:C" & maxCount).Find(What:="T") Is Nothing Then
'            Selection.Find.MatchWildcards = True
            bUseWC = True ' defaults to False
        End If
    End With
    
    objWb.Close SaveChanges:=False
    If F Then
        objExcel.Quit
    End If
    
'    Application.ScreenUpdating = False  ' not needed for Range instead of Selection
    Options.DefaultHighlightColorIndex = wdYellow
'    Selection.HomeKey Unit:=wdStory
    
    Set oRng = ActiveDocument.Range ' search whole document
    With oRng.Find
'        .ClearFormatting   ' not needed for Range
'        .Replacement.ClearFormatting
        .MatchWildcards = bUseWC   ' from worksheet
        .Replacement.Highlight = True
        .Replacement.Text = "^&"
        .Wrap = wdFindStop
        For iCount = 1 To maxCount - 1
            If VChar(iCount, 1) <> "" Then
                .Execute FindText:=VChar(iCount - 1), Replace:=wdReplaceAll
            End If
        Next iCount
    End With

'    Application.ScreenUpdating = True  ' not needed for Range
End Sub

[snb]

Try:

Code: Select all

Sub M_snb()
   sn = GetObject("G:\OF\Reference.xlsx").sheets(1).usedrange
   ActiveDocument.TrackRevisions = True
   
   With ActiveDocument.Range.Find
      For j = 1 To UBound(sn)
        .Execute sn(j, 1), True, , , , , , , , sn(j, 2), 2
      Next
   End With
End Sub[/code)

[vincent546]

I'm not sure whether this will make the code any faster, but I don't have the setup to test it...

Manipulating Word's Selection object affects not just the screen display of the document (which is turned off by setting ScreenUpdating = False) but also its internal representation. Instead, you can use a Range object, which is not connected to any display code. It doesn't move the cursor or cause any scrolling, and doesn't trigger any pagination code.

If you want to try it, here's a modified version of Hans' code.

Code: Select all

Sub H()

    Dim cellData As Variant
    Dim maxCount As Long, iCount As Long  ' without As Long, maxCount will be Variant
    Dim oRng As Word.Range  ' Word.Range is not like Excel.Range
    Dim bUseWC As Boolean   ' holder for MatchWildcards value
    Dim excelPath As String
    Dim objExcel As Object
    Dim objWb As Object
    Dim F As Boolean
    Dim VChar As Variant
   
    excelPath = "E:\H.xlsx"

    On Error Resume Next
    Set objExcel = GetObject(Class:="Excel.Application")
    If objExcel Is Nothing Then
        Set objExcel = CreateObject(Class:="Excel.Application")
        F = True
    End If
    Set objWb = objExcel.Workbooks.Open(filename:=excelPath)
    
    With objWb.Sheets(1)
        maxCount = .Cells(.Rows.Count, 1).End(-4162).Row
        VChar = .Range("A2:A" & maxCount).Value
        If Not .Range("C2:C" & maxCount).Find(What:="T") Is Nothing Then
'            Selection.Find.MatchWildcards = True
            bUseWC = True ' defaults to False
        End If
    End With
    
    objWb.Close SaveChanges:=False
    If F Then
        objExcel.Quit
    End If
    
'    Application.ScreenUpdating = False  ' not needed for Range instead of Selection
    Options.DefaultHighlightColorIndex = wdYellow
'    Selection.HomeKey Unit:=wdStory
    
    Set oRng = ActiveDocument.Range ' search whole document
    With oRng.Find
'        .ClearFormatting   ' not needed for Range
'        .Replacement.ClearFormatting
        .MatchWildcards = bUseWC   ' from worksheet
        .Replacement.Highlight = True
        .Replacement.Text = "^&"
        .Wrap = wdFindStop
        For iCount = 1 To maxCount - 1
            If VChar(iCount, 1) <> "" Then
                .Execute FindText:=VChar(iCount - 1), Replace:=wdReplaceAll
            End If
        Next iCount
    End With

'    Application.ScreenUpdating = True  ' not needed for Range
End Sub

Many thanks for your help. But it cannot highlight specific text based on an excel file.....anyway, i will further investigate the reasons. Thanks again for your help!

[vincent546]

Thank you snb.
Should I put the code into "ThisDocument" instead of a module?

[snb]

If you have any idea of working in VBA you should know.

[HansV]

snb's code is an ordinary macro, so it belongs in a standard module.