der mir zu diesem Thema helfen konnte!
Das VBA-Programm kann schon fast das, was es soll! Super!
Vielen Dank nochmal!
lg roman
'Erstellt unter MS Office 2010
'Code in einem allgemeinen VBA-Modul der Exceldatei
Sub Hole_Wordtexte()
Dim strFileName As String
Dim objWDApp As Object 'Word.Application
Dim objDoc As Object 'Word.Document
Dim wdRange As Object ' Word.Range
Dim wks As Worksheet
Dim strText As String
Dim letztezeile
Dim varVerzeichnis
'On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis mit den Worddateien auswählen"
If .Show = -1 Then
varVerzeichnis = .SelectedItems(1)
Else
GoTo Beenden
End If
End With
Set wks = ActiveSheet
With wks
letztezeile = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
strFileName = Dir(varVerzeichnis & "\" & "*.doc")
If strFileName "" Then
Set objWDApp = CreateObject("Word.Application")
objWDApp.Visible = True
Else
MsgBox "Keine Worddateien im gewählten Verzeichnis"
GoTo Beenden
End If
Do Until strFileName = ""
'Worddatei schreibgeschützt öffnen
Set objDoc = objWDApp.Documents.Open(varVerzeichnis & "\" & strFileName, _
ReadOnly:=True)
'nächste freie Zeile Zeile in Excelblatt in Spalte B
With wks
letztezeile = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
'Worddateiname
.Cells(letztezeile, 1) = objDoc.Name
'Text aus 3. Absatz/Paragraph übernehmen
Set wdRange = objDoc.Paragraphs(3).Range
strText = wdRange.Text
'Projekt-Nummer / Name
'Ort abtrennen
strText = Trim(Left(strText, InStrRev(strText, "-") - 1))
'"Projektnummer:" abschneiden
strText = Trim(Mid(strText, Len("Projektnummer:") + 1))
.Cells(letztezeile, 2) = "'" & Trim(Left(strText, InStrRev(strText, "-") - 1)) 'Projekt- _
Nr
.Cells(letztezeile, 3) = "'" & Trim(Mid(strText, InStrRev(strText, "-") + 1)) 'Proj.-Name
'Text aus 4. Absatz/Paragraph übernehmen
Set wdRange = objDoc.Paragraphs(4).Range
strText = wdRange.Text
'"Adresse:" abschneiden
strText = Trim(Mid(strText, Len("Adresse:") + 1))
.Cells(letztezeile, 4) = "'" & Trim(Left(strText, InStr(strText, ", ") - 1)) 'Strasse
'Strasse abtrennen
strText = Trim(Mid(strText, InStr(strText, ", ") + 2))
.Cells(letztezeile, 5) = "'" & Mid(strText, 1, InStr(strText, " ") - 1) 'PLZ
.Cells(letztezeile, 6) = "'" & Mid(strText, InStr(strText, " ") + 1) 'Ort
End With 'wks
'Worddatei wieder schliessen
objDoc.Close savechanges:=False
strFileName = Dir
Loop
'Word-Anwendung beenden
objWDApp.Quit
Beenden:
End Sub