macro version. 3

Sub GrammarCheckOptimized()
    Dim doc As Document
    Dim incorrectWord As Variant ' Change the type to Variant
    Dim replacementWord As String
    Dim correctionsDict As Object
    Dim excelApp As Object, workbook As Object, sheet As Object
    Dim row As Long, lastRow As Long
    Dim findRange As Range
    Dim wordFilePath As String
    Dim summaryFileName As String
    Dim summaryFile As Object
    Dim fso As Object
    
    ' Set the active document
    Set doc = ActiveDocument
    
    ' Disable screen updating and pagination for speed
    Application.ScreenUpdating = False
    Application.Options.Pagination = False
    
    ' Define the Excel file path for grammar corrections
    Dim excelFilePath As String
    excelFilePath = "C:\path\to\your\correction_file.xlsx" ' Update with your Excel path
    
    ' Open Excel
    Set excelApp = CreateObject("Excel.Application")
    excelApp.Visible = False
    Set workbook = excelApp.Workbooks.Open(excelFilePath)
    Set sheet = workbook.Sheets(1)
    
    ' Create a dictionary for corrections
    Set correctionsDict = CreateObject("Scripting.Dictionary")
    
    ' Find the last row in the Excel sheet
    lastRow = sheet.Cells(sheet.Rows.Count, 1).End(-4162).Row ' -4162 is equivalent to xlUp
    
    ' Load corrections from Excel into the dictionary
    For row = 2 To lastRow
        incorrectWord = sheet.Cells(row, 1).Value
        replacementWord = sheet.Cells(row, 2).Value
        
        ' Check if the key (incorrectWord) already exists
        If Not correctionsDict.Exists(incorrectWord) Then
            correctionsDict.Add incorrectWord, replacementWord
        End If
    Next row
    
    ' Close the Excel workbook
    workbook.Close False
    excelApp.Quit
    Set excelApp = Nothing
    
    ' Prepare the summary file
    wordFilePath = doc.FullName
    summaryFileName = Left(wordFilePath, Len(wordFilePath) - 5) & "_summary.txt" ' Add _summary to file name
    
    ' Create a new summary text file
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set summaryFile = fso.CreateTextFile(summaryFileName, True)
    
    ' Write changes to the Word document and the summary file
    For Each incorrectWord In correctionsDict.Keys ' Ensure incorrectWord is Variant
        Set findRange = doc.Content
        With findRange.Find
            .Text = incorrectWord
            .Replacement.Text = correctionsDict(incorrectWord)
            .Execute Replace:=wdReplaceAll
        End With
        ' Log the changes in summary file
        summaryFile.WriteLine "Original Word: " & incorrectWord
        summaryFile.WriteLine "Replaced With: " & correctionsDict(incorrectWord)
        summaryFile.WriteLine "=================================================="
    Next incorrectWord
    
    ' Close the summary file
    summaryFile.Close
    
    ' Re-enable screen updates
    Application.ScreenUpdating = True
    Application.Options.Pagination = True
    
    ' Display completion message
    MsgBox "Grammar check completed. Summary saved as: " & summaryFileName, vbInformation
End Sub