AW: bestimmte Zeilen aus Word-Datei auslesen - Franz
11.08.2014 12:56:44
fcs
Hallo Roman,
hier das Makro mit Anpassungen, um die Zeileninhalte auf verschiedene Spalten der Zeile zu verteilen.
Ich hatte etwas Probleme mit dem Bindestrich in der Zeile mit der Projektnummer im Wordtext. Das Makro sucht jetzt nach dem Minuszeichen.
Falls in deinen Wordtexten ein anderes Zeichen als Bindestrich verwendet wird, dann muss nochmals angepasst werden.
Gruß
Franz
'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