Private Sub FillWithTypeText()

On Error GoTo ErrorHandler
    Dim appWord As Word.Application
    Dim doc As Word.Document
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    
    Set appWord = GetObject(, "Word.Application")
    Set doc = appWord.Documents.Add

'insert format document titel
    With appWord.Selection
        .TypeText "Aktuelle Kontakte mit " _
            & Format(Date, "Long Date")
        .TypeParagraph
        .MoveLeft Unit:=wdWord, count:=11, _
            Extend:=wdExtend
        .Font.Size = 14
        .Font.Bold = wdToggle
        .MoveDown Unit:=wdLine, count:=1
    End With
    
'insert two column table to hold contact data(one column for contact names, the other for user comments)
    doc.Tables.Add Range:=Selection.Range, _
        NumRows:=1, _
        NumColumns:=2, _
        DefaultTableBehavior:=wdWord9TableBehavior, _
        AutoFitBehavior:=wdAutoFitFixed
        
    With appWord.Selection.Tables(1)
        If .Style <> "Table Grid" Then
            .Style = "Table Grid"
        End If
        
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = False
        .ApplyStyleRowBands = True
        .ApplyStyleColumnBands = False
    End With
    
'insert contact Data from Access table into Word table:
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("tblKunden")
    Do While Not rst.EOF
        With appWord.Selection
            .TypeText rst![kunKundenAnzeigen]
            .MoveRight Unit:=wdCell, count:=2
        End With
        rst.MoveNext
    Loop
    
'Delete the last names alphabetically:
    doc.Tables(1).Select
    appWord.Selection.Sort excludeheader:=False, _
        fieldnumber:="Column 1", _
        sortfieldtype:=wdSortFieldAlphanumeric, _
        SortOrder:=wdSortOrderAscending
        
ErrorHandlerExit:
    Set appWord = Nothing
    Exit Sub
    
ErrorHandler:
    If Err = 429 Then
    
'Word is not running: open Word with createObject:
    Set appWord = CreateObject("Word.Application")
    Resume Next
    Else
        MsgBox "Error No: " & Err.Number _
        & " ; Description: " & Err.Description
        Resume ErrorHandlerExit
    End If
    
End Sub