Sub
ExportVonWordInExcel4automatisiert()
Dim
w
As
Word.Application
Dim
d
As
Word.Document
Dim
tbl
As
Word.Table, tblRow
As
Word.Row
Dim
xltbl
As
Integer
, xlcol
As
Integer
Dim
ws
As
Worksheet
Dim
i
As
Long
Dim
dateipfad
As
String
Dim
dateiname
As
String
Dim
dateiauswahl
As
FileDialog
Set
ws = ActiveSheet
On
Error
Resume
Next
Set
w = GetObject(
"word.application"
)
If
Err.Number <> 0
Then
Set
w = CreateObject(Word.Application)
Err.Clear
Set
w = CreateObject(
"word.application"
)
w.Visible =
True
End
If
Set
dateiauswahl = Application.FileDialog(msoFileDialogFilePicker)
With
dateiauswahl
.Title =
"wählen Sie eine Datei aus"
.Filters.Clear
.Filters.Add
"Word-Dateien"
,
"*.doc*; *.docx"
.AllowMultiSelect =
False
If
.Show <> -1
Then
Exit
Sub
End
If
dateipfad = Left(.SelectedItems(1), InStrRev(.SelectedItems(1),
"/"
))
dateiname = Mid(.SelectedItems(1), InStrRev(.SelectedItems(1),
"/"
) + 1)
d.Open (dateipfad & dateiname)
End
With
Set
d = w.ActiveDocument
xltbl = (Worksheets(1).UsedRange.Rows.Count - 1) + Worksheets(1).UsedRange.Row
For
Each
tbl
In
d.Tables
xltbl = xltbl + 1
xlcol = 0
For
Each
tblRow
In
tbl.Rows
xlcol = xlcol + 1
Worksheets(1).Cells(xltbl, xlcol).Value = Left(tblRow.Cells(2).Range.Text, Len(tblRow.Cells(2).Range.Text) - 1)
Next
Next
d.Close
False
Set
d =
Nothing
w.Quit
Set
w =
Nothing
Set
ws =
Nothing
End
Sub