Option Explicit

Sub AddListToCustomDictionary()

Dim doc As Word.Document
Dim wrd As Word.Range
Dim i As Integer
Dim oCustDic As Object
Dim sCustDicPath As String
Dim fso As Object
Dim txt As Object

Set doc = ActiveDocument
Set oCustDic = Application.CustomDictionaries.ActiveCustomDictionary
sCustDicPath = oCustDic.Path + "\" + oCustDic.Name
Set fso = CreateObject("Scripting.FileSystemObject")
Set txt = fso.OpenTextFile(sCustDicPath, 8, True, -1)

For i = 1 To doc.Words.Count
    Set wrd = doc.Words(i)
    If InStr(wrd, Chr(13)) = 0 Then
        txt.WriteLine wrd
    End If
Next

txt.Close

End Sub