Sub Word_nach_Excel()
Dim xlApp As Excel.Application
Dim xlWkb As Excel.Workbook
Dim xlWks As Excel.Worksheet
Dim oDoc As Document
Dim lngFreieZeile As Long
On Error Resume Next
Set oDoc = ActiveDocument
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Err.Clear
Set xlApp = CreateObject("Excel.Application"): DoEvents
xlApp.Visible = True
End If
Set xlWkb = xlApp.Workbooks.Open("C:\test.xls")
Set xlWks = xlWkb.Worksheets(1)
With xlWks
lngFreieZeile = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row + 1
.Cells(lngFreieZeile, 1) = oDoc.Bookmarks("Text1").Range.Text
.Cells(lngFreieZeile, 2) = oDoc.FormFields("Dropdown1").Result
If oDoc.FormFields("Kontrollkästchen1").CheckBox.Value = True Then
.Cells(lngFreieZeile, 3) = "ja"
ElseIf oDoc.FormFields("Kontrollkästchen1").CheckBox.Value = False Then
.Cells(lngFreieZeile, 3) = "nein"
End If
If Err.Number = 0 Then
MsgBox "Alle Eingabefelder erfolgreich übertragen.", vbInformation, "Info..."
Else
Err.Clear
MsgBox "Nicht alle Eingabefelder übertragen!", vbCritical, "Fehler..."
End If
End With
xlWkb.Close True
Set xlWks = Nothing
Set xlWkb = Nothing
xlApp.Quit
Set xlApp = Nothing
Set oDoc = Nothing
End Sub