final version 5

Sub CheckSTEWordsStructuredTechnicalEnglish()
    Dim doc As Document
    Dim incorrectWord As Variant
    Dim replacementWord As String
    Dim correctionsDict As Object
    Dim wordRange As Range
    Dim excelApp As Object, workbook As Object, sheet As Object
    Dim row As Long, lastRow As Long
    Dim excelFilePath As String
    Dim selectedRange As Range
    Dim updateCount As Long

    ' Ensure there is a selection
    If Selection.Type = wdNoSelection Then
        MsgBox "Please select the text to be checked.", vbExclamation
        Exit Sub
    End If

    ' Set the active document and selected range
    Set doc = ActiveDocument
    Set selectedRange = Selection.Range

    ' Specify the Excel file path containing corrections
    excelFilePath = "C:\path\to\your\correction_file.xlsx" ' Update this path

    ' Initialize the dictionary
    Set correctionsDict = CreateObject("Scripting.Dictionary")

    ' Open Excel
    On Error Resume Next
    Set excelApp = CreateObject("Excel.Application")
    If excelApp Is Nothing Then
        MsgBox "Excel could not be started. Make sure Excel is installed.", vbCritical
        Exit Sub
    End If
    excelApp.Visible = False
    Set workbook = excelApp.Workbooks.Open(excelFilePath)
    On Error GoTo 0

    If workbook Is Nothing Then
        MsgBox "The specified Excel file could not be opened. Please check the file path.", vbCritical
        excelApp.Quit
        Set excelApp = Nothing
        Exit Sub
    End If

    Set sheet = workbook.Sheets(1)
    lastRow = sheet.Cells(sheet.Rows.Count, 1).End(-4162).Row ' -4162 is xlUp

    ' Load corrections into the dictionary
    For row = 2 To lastRow
        incorrectWord = Trim(LCase(sheet.Cells(row, 1).Value))
        replacementWord = Trim(sheet.Cells(row, 2).Value)
        If Not correctionsDict.Exists(incorrectWord) Then
            correctionsDict.Add incorrectWord, replacementWord
        End If
    Next row

    ' Close Excel
    workbook.Close False
    excelApp.Quit
    Set excelApp = Nothing

    ' Initialize counters
    updateCount = 0

    ' Main loop for grammar check
    For Each wordRange In selectedRange.Words
        ' Process only words that are not underlined
        If wordRange.Font.Underline = wdUnderlineNone Then
            Dim coreWord As String
            coreWord = Trim(LCase(wordRange.Text))

            ' Check if word is in corrections dictionary and doesn't already have suggestion appended
            If correctionsDict.Exists(coreWord) And InStr(wordRange.Text, "(" & correctionsDict(coreWord) & ")") = 0 Then
                ' Append the replacement in parentheses only if it hasn't already been appended
                wordRange.Text = wordRange.Text & " (" & correctionsDict(coreWord) & ")"
                
                ' Underline the word to mark it as processed
                wordRange.Font.Underline = wdUnderlineSingle
            End If
        End If

        ' Increment counter and allow Word to process events
        updateCount = updateCount + 1
        If updateCount Mod 10 = 0 Then DoEvents
    Next wordRange

    ' Final cleanup
    Application.ScreenUpdating = True
    Application.StatusBar = "Grammar check completed."

    ' Display completion message
    MsgBox "Grammar check completed.", vbInformation
End Sub