Tutorial: Word-Vorlage mit Daten aus Excel befüllen

Option Explicit
Option Compare Text
' Original-Quelltext unter: https://www.online-vba.de/vba-tutorial-vorlage-mit-werten-aus-excel-fuellen
' Express-Hilfe für VBA unter https://www.online-vba.de/vba-expresshilfe
' Es gelten die Nutzungsbedingungen von Online-VBA.de

'In dieser Konstanten speichern wir uns
'den Pfad und den Dateinamen der Adressliste (Excel)
'Bitte entsprechend anpassen!
Private Const sAdressDatei As String = _
    "C:\TEST\TutorialWordMitExcelFuellen\MeineAdressen.xlsx"

'Wie heisst das Tabellenblatt, auf welchem sich die Adressen befinden?
'Bitte entsprechend anpassen!
Private Const sTabellenblatt As String = "Tabelle1"

Private Sub CommandButton1_Click()
  Dim oExcelApp As Object
  Dim oExcelWorkbook As Object
  Dim lZeile As Long
    
    'Nur wenn ein Eintrag in der Liste markiert ist, wird das Makro ausgeführt
    If ListBox1.ListIndex >= 0 Then
        
        'Zuerst wird die Excel Datei geöffnet
        Set oExcelApp = CreateObject("Excel.Application")
        Set oExcelWorkbook = oExcelApp.Workbooks.Open(sAdressDatei)
        
        lZeile = 2 'Wir starten in Zeile 2, da in der ersten Zeile überschriften stehen
        With oExcelWorkbook.sheets(sTabellenblatt)
            Do While .Cells(lZeile, 1) <> ""
                'Wenn der Eintrag der Listbox mit dem Namen in der Adresstabelle
                'übereinstimmt, dann werden die Textmarken gefüllt!
                If ListBox1.Text = CStr(.Cells(lZeile, 2).Value) Then
                    'Eintrag gefunden, Textmarken füllen
                    ActiveDocument.Bookmarks("Textmarke_Name").Range.Text = _
                        CStr(.Cells(lZeile, 2).Value)
                    ActiveDocument.Bookmarks("Textmarke_Adresse").Range.Text = _
                        CStr(.Cells(lZeile, 3).Value)
                    ActiveDocument.Bookmarks("Textmarke_PLZ_Ort").Range.Text = _
                        CStr(.Cells(lZeile, 4).Value)
                    Exit Do
                End If
                lZeile = lZeile + 1
            Loop
        End With
        
        oExcelWorkbook.Close False
        oExcelApp.Quit
    
    Else
        MsgBox "Bitte wählen Sie einen Eintrag aus der Liste aus!", _
            vbInformation + vbOKOnly, "HINWEIS!"
        Exit Sub
    End If

  Set oExcelWorkbook = Nothing
  Set oExcelApp = Nothing
  Unload Me
End Sub

Private Sub CommandButton2_Click()
    Unload Me
End Sub

Private Sub UserForm_Initialize()
  Dim oExcelApp As Object
  Dim oExcelWorkbook As Object
  Dim lZeile As Long
    
    'Zuerst wird die Excel Datei geöffnet
    Set oExcelApp = CreateObject("Excel.Application")
    Set oExcelWorkbook = oExcelApp.Workbooks.Open(sAdressDatei)
    
    ListBox1.Clear
    lZeile = 2 'Wir starten in Zeile 2, da in der ersten Zeile überschriften stehen
    With oExcelWorkbook.sheets(sTabellenblatt)
        Do While .Cells(lZeile, 1) <> ""
            ListBox1.AddItem CStr(.Cells(lZeile, 2).Value)
            lZeile = lZeile + 1
        Loop
    End With
    
    oExcelWorkbook.Close False
    oExcelApp.Quit
    
  Set oExcelWorkbook = Nothing
  Set oExcelApp = Nothing
End Sub