VBA从excel列表中自动添加word中的自动更正项

Sub AddAutoCorrectEntries()
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Dim i As Long
    
    ' 初始化Excel应用程序对象
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Open("C:\path\to\your\excel\file.xlsx")
    Set xlSheet = xlBook.Sheets(1)
    
    ' 初始化Word应用程序对象
    Set wrdApp = CreateObject("Word.Application")
    wrdApp.Visible = True
    Set wrdDoc = wrdApp.Documents.Open("C:\path\to\your\word\file.docx")
    
    ' 遍历Excel列表并添加自动更正项
    For i = 1 To xlSheet.Cells(Rows.Count, "A").End(xlUp).Row
        With wrdApp.Options.AutoCorrect
            .AddReplacement xlSheet.Cells(i, 1).Value, xlSheet.Cells(i, 2).Value
        End With
    Next i
    
    ' 关闭文档和应用程序
    wrdDoc.Close SaveChanges:=True
    xlBook.Close SaveChanges:=False
    xlApp.Quit
    wrdApp.Quit
    
    MsgBox "自动更正项已成功添加！"
End Sub