In einem Word Dokument anhand eines Schlüsselwortes 1 oder 2 Bilder aus einem bestimmten Ordner einfügen. Der Pfad und die Bildnamen zum Schlüsselwort stehen in einer Excel Datei

Sub InsertImagesForKeyword()
    'Variablen  
    Dim pathData As String, strKeyword As String, pos As Range, cell As Object, img As InlineShape, c As Object, strImagePath As String, fso as Object
    
    'Pfad zur Daten xlsx (hier der selbe Pfad wie das aktuelle Dokument  
    pathData = ThisDocument.Path & "\Daten.xlsx"  
    
    ' Wenn kein Keyword ausgewählt wurde beende Sub  
    If Selection.Range.Characters.Count = 1 Then
        MsgBox "Bitte markieren sie ein Keyword!", vbExclamation  
        Exit Sub
    End If
    
    'Objekte initialisieren  
    Set fso = CreateObject("Scripting.FileSystemObject")  
    
    ' Keyword ist der markierte Text  
    strKeyword = Trim(Selection.Text)
    
    'Excel-Workbook zum lesen öffnen  
    With GetObject(pathData).Sheets(1)
        'Suche nach Keyword in Spalte A des ersten Worksheets durchführen  
        Set c = .Range("A:A").Find(strKeyword, LookIn:=-4163)  
        ' Wurde das Keyword gefunden ...  
        If Not c Is Nothing Then
            ' Inhalt der Selektion löschen  
            Selection.Delete
            'Für jedes Bild in der gefundenen Zeile zum Keyword Zeile X Spalte C:<N>  
            For Each cell In .Range(c.Offset(0, 2), .Cells(c.Row, .Columns.Count).End(-4159))
                'absoluter Pfad des Bildes zusammensetzen  
                strImagePath = c.Offset(0, 1).Value & "\" & cell.Value  
                'Wenn Bild existiert  
                If fso.FileExists(strImagePath) Then
                    'füge das Bild ein  
                    Set img = Selection.InlineShapes.AddPicture(strImagePath, True, True)
                    'Setze die Größe des Bildes  
                    img.Width = CentimetersToPoints(15.1)
                    img.Height = CentimetersToPoints(10.1)
                    'Füge zwei Absätze ein  
                    Selection.Range.InsertParagraphAfter
                    Selection.Range.InsertParagraphAfter
                    'Verschiebe die Selection 2 Absätze nach unten  
                    Selection.MoveDown wdParagraph, 2
                Else
                    MsgBox "Bild mit dem Pfad: " & strImagePath & "' wurde existiert nicht!", vbExclamation  
                End If
            Next
        Else
            'Kein Eintrag für das Keyword gefunden  
            MsgBox "Keyword wurde in der Datenbank nicht gefunden!", vbExclamation  
        End If
        'Workbook schließen  
        .Parent.Close False
    End With
    
    'Cleanup  
    Set fso = Nothing
End Sub