Formular Daten in Excel importieren

Set lo = WS.ListObjects("MeineDatenTabelle")  

If LCase(strFuehrung) = "true" Then  
    lo.ListRows(lo.ListRows.Count).Range(1, 3).Text = "ja"  
Else
    lo.ListRows(lo.ListRows.Count).Range(1, 3).Text = "nein"  
End If

Sub btnImportForms()
    On Error Resume Next
    Dim ws As Worksheet, objWord As Object, doc As Object, cXML As CustomXMLPart, myXMLPart As CustomXMLPart, dlg As FileDialog, n As Long
    'Tabelle im Dokument referenzieren  
    Set ws = Worksheets(1)
    'Word Objekt erzeugen  
    Set objWord = CreateObject("Word.Application")  
    objWord.Visible = False
    objWord.DisplayAlerts = False
    'Dateiauswahl-Dialog erstellen  
    Set dlg = Application.FileDialog(msoFileDialogFilePicker)
    With dlg
        'Einstellungen für den Dialog setzen  
        .AllowMultiSelect = True
        .Title = "Bitte markieren sie ein oder mehere Formulare deren Daten importiert werden sollen"  
        .Filters.Add "Word Dateien", "*.docx; *.docm", 1  
        .FilterIndex = 1
        ' Wenn der Dialog mit OK geschlossen wurde mache weiter  
        If .Show = -1 Then
            ' Für jedes Dokument das im Dialog ausgewählt wurde ..  
            For i = 1 To .SelectedItems.Count
                'Öffne das Dokument  
                Set doc = objWord.Documents.Open(.SelectedItems(i))
                ' Suche das CustomXML im Dokument  
                For Each cXML In doc.CustomXMLParts
                    If cXML.BuiltIn = False Then
                        Set rootNode = cXML.SelectSingleNode("root")  
                        If Not rootNode Is Nothing Then
                            Set myXMLPart = cXML
                            Exit For
                        End If
                    End If
                Next
                'Wenn der CustomXML-Part gefunden wurde ...  
                If Not myXMLPart Is Nothing Then
                    'Alle Felder holen  
                    Set objNodes = myXMLPart.SelectNodes("/root/*")  
                    'Daten der Felder in Arrays schreiben  
                    Dim headers() As String
                    Dim values() As String
                    For n = 1 To objNodes.Count
                        ReDim Preserve headers(1 To n)
                        ReDim Preserve values(1 To n)
                        headers(n) = objNodes(n).BaseName
                        values(n) = objNodes(n).Text
                    Next
                    
                    'Wenn Überschriften noch nicht gesetzt sind ...  
                    If i = 1 Then
                        'Überschriften ins Sheet in Zeile 5 schreiben  
                        With ws.Range("A5").Resize(1, UBound(headers))  
                            .Value = headers
                            .Font.Bold = True
                        End With
                    End If
                    'Ergänze die Daten der Felder in der nächsten unbelegten Zeile  
                    ws.Range("A" & ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Resize(1, UBound(values)).Value = values  
                    
                End If
                'Dokument schließen  
                doc.Close False
            Next
        End If
    End With
    
    'Word schließen  
    objWord.DisplayAlerts = False
    objWord.Quit
    Set objWord = Nothing
End Sub

'           Finde den Dateinamen und -pfad heraus +Hyperlink  
            DocName1 = Right(File, Len(File) - InStrRev(File, "\"))  
            DocName2 = Left(DocName1, (InStrRev(DocName1, ".") - 1))  
            ActiveSheet.Hyperlinks.Add Anchor:=Lo.ListRows(Lo.ListRows.Count).Range(1, 2), _
            Address:=File, ScreenTip:=File, TextToDisplay:=DocName2