Importing AutoCorrect Entries

'This macro work with Office 2016
'--------------------------------


'Export all autocorrect entries
Sub ListTheAutoCorrectList()
Dim ACE As AutoCorrectEntry
Documents.Add
For Each ACE In Application.AutoCorrect.Entries
Selection.TypeText ACE.Name & vbTab & ACE.Value & vbCr
Next
With ActiveDocument.PageSetup.TextColumns
.SetCount NumColumns:=1
.EvenlySpaced = True
.LineBetween = True
End With
ActiveDocument.Paragraphs.TabStops(InchesToPoints(1.88)).Position = _
InchesToPoints(1.88)
End Sub

Sub AddToTheAutoCorrectList()
Dim r As Range, r1 As Range
Dim par As Paragraph, bo As Boolean
Dim pars As Paragraphs
Dim ACE As AutoCorrectEntry
Dim ACEs As AutoCorrectEntries
Dim ActD As Document

Set ActD = ActiveDocument
Set pars = ActD.Paragraphs
Set r1 = Selection.Range
Set r = Selection.Range
Set ACEs = Application.AutoCorrect.Entries

On Error Resume Next
For Each par In pars
If par.Range.End = ActD.Content.End Then Exit Sub
r1.Start = par.Range.Start
r1.End = r1.Start
r1.MoveEndUntil vbTab
r.Start = r1.End + 1
r.End = par.Range.End - 1
If Len(r1.Text) > 0 Or Len(r.Text) > 0 Then
reemplazo = ACEs(r1.Text).Value
Len_reemplazo = Len(reemplazo)
If Len_reemplazo <> 0 Then
bo = Repl(ACEs, r, r1)
Else
bo = True
End If
If bo Then
ACEs.Add r1.Text, r.Text
End If
End If
Next
End Sub

Private Function Repl(a As AutoCorrectEntries, _
r As Range, r1 As Range) As Boolean
If a(r1.Text).Value = r.Text Then
Repl = MsgBox("To replace " & UCase(a(r1.Text).Value) & _
" with " & UCase(r.Text) & " click OK", vbYesNo + _
vbQuestion, "REPLACE ENTRY?") = vbYes
End If
End Function

'For file with many duplicate entries
Sub AddToTheAutoCorrectListWithoutQuestion()
Dim r As Range, r1 As Range
Dim par As Paragraph, bo As Boolean
Dim pars As Paragraphs
Dim ACE As AutoCorrectEntry
Dim ACEs As AutoCorrectEntries
Dim ActD As Document

Set ActD = ActiveDocument
Set pars = ActD.Paragraphs
Set r1 = Selection.Range
Set r = Selection.Range
Set ACEs = Application.AutoCorrect.Entries

On Error Resume Next
For Each par In pars
If par.Range.End = ActD.Content.End Then Exit Sub
r1.Start = par.Range.Start
r1.End = r1.Start
r1.MoveEndUntil vbTab
r.Start = r1.End + 1
r.End = par.Range.End - 1
If Len(r1.Text) > 0 Or Len(r.Text) > 0 Then
reemplazo = ACEs(r1.Text).Value
Len_reemplazo = Len(reemplazo)
If Len_reemplazo <> 0 Then
bo = True
End If
If bo Then
ACEs.Add r1.Text, r.Text
End If
End If
Next
End Sub

love this idea, how can I prepare my data for this. I can make a comma separated file, but how do I add the paragraph after each entry

I also loaded in this macro and it didn't work. I'm using Word within Office365 - maybe that makes a difference?

Hi. Can you write a macro that I can use in xcel. I can then assign the macro to a button. The text and replacement can be in separate columns. Then all one has to do is click on the button to activate the autocorrect update.
I am planning to use this for a language - non Latin based to Latin script transliteration method and the user who is not computer literate will find it easier to use. All they to do then is download the xcel file and click to update the autocorrect.
Thanks Aboo

This works very well (thank you!) for regular text, but is it possible to make it work for formatted text?

Hi Allen,
I must be missing something. I copied your macro and inserted into VB for Office 2010. When I run it nothing happens. When I step through it, each line seems to execute, but nothing happens in the document (set up as specified) and no entries are inserted in AutoCorrect.

Can you help?

Thank you.