Bestimmte_Zeilen_aus_WordDatei_auslesen

Hallo,
ich suche nach einer Möglichkeit in Excel bestimmte Inhalte einer Vielzahl von Word-Dateien auszulesen.
Es sollen alle Word-Dokumente, die in einem bestimmten Ordner liegen ausgewertet werden.
Ausgegeben werden sollen alle Zeilen, die zwischen zwei Suchbegriffen liegen.
Suchbegriff 1: Leistungsanforderung
Suchbegriff 2: Kostenkalkulation
Zwischen den beiden Begriffen kann nur eine Zeile stehen, es können aber auch 30 Zeilen dazwischen stehen.
Die Ausgabe soll wie folgt aussehen:
Spalte A: Dateiname
Spalte B: Vollständiger Zeileninhalt
Folgender Beitrag scheint mir in die gleiche Richtung zu gehen, ich bekomme die entsprechende Modifizierung aber leider nicht hin.
https://www.herber.de/forum/archiv/1372to1376/1374285_bestimmte_Zeilen_aus_WordDatei_auslesen__Franz.html#1374285
Viele Grüße

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Hole_Wordtexte() Dim strFileName As String 'Pfad und Dateiname Dim objWDApp As Object 'Word Applikation Dim strSuchText1 As String 'Suchbegriff 1 = Anfang Dim strSuchText2 As String 'Suchbegriff 2 = Ende strFileName = "C:\Temp\TestDokument.docx" 'Anpassen!! On Error GoTo FBRoutine 'bei Fehler zur Fehlerbehandlung Set objWDApp = CreateObject("Word.Application") objWDApp.Visible = True objWDApp.documents.Open strFileName strSuchText1 = "Anfangs-Suchtext" 'Anpassen! strSuchText2 = "Ende-Suchtext4" 'Anpassen! With objWDApp.Activedocument.Range If .Find.Execute(strSuchText1) Then vStart = .Start + 1 End With With objWDApp.Activedocument.Range If .Find.Execute(strSuchText2) Then vLast = .Start - 1 End With objWDApp.Activedocument.Range(Start:=vStart, End:=vLast).Copy Range("A1") = strFileName Range("B1").PasteSpecial Paste:=xlPasteValues objWDApp.Activedocument.Close savechanges:=False objWDApp.Quit FBRoutine: MsgBox "Es ist ein Fehler ausgetreten. ErrorNummer = " & Err.Number, vbCritical + vbOKOnly, "Hinweis" End Sub

Sub getDocListe() Dim lngAnzahl As Long Dim strDatei As String Dim strDateien() As String Dim myPath As String myPath = "C:\Users\wordfiles" 'Anpassen strDatei = Dir(myPath & "\*.doc") 'Anpassen; nur *.doc ? oder auch *,docx ? Do While Len(strDatei) If strDatei ThisWorkbook.Name Then lngAnzahl = lngAnzahl + 1 ReDim Preserve strDateien(1 To lngAnzahl) strDateien(lngAnzahl) = strDatei Call Hole_Wordtexte(myPath, strDatei) End If strDatei = Dir Loop End Sub Sub Hole_Wordtexte(myPath, strDatei) Dim strFileName As String 'Pfad und Dateiname Dim objWDApp As Object 'Word Applikation Dim strSuchText1 As String 'Suchbegriff 1 = Anfang Dim strSuchText2 As String 'Suchbegriff 2 = Ende Dim ze As Long strFileName = myPath & "\" & strDatei strSuchText1 = "Anfangs-Suchtext" 'Anpassen! strSuchText2 = "Ende-Suchtext4" 'Anpassen! On Error GoTo FBRoutine 'bei Fehler zur Fehlerbehandlung Set objWDApp = CreateObject("Word.Application") objWDApp.Visible = True objWDApp.documents.Open strFileName With objWDApp.Activedocument.Range If .Find.Execute(strSuchText1) Then vStart = .Start + 1 End With With objWDApp.Activedocument.Range If .Find.Execute(strSuchText2) Then vLast = .Start - 1 End With objWDApp.Activedocument.Range(Start:=vStart, End:=vLast).Copy With Sheets("Tabelle1") ze = .Cells(Rows.Count, 1).End(xlUp).Row + 1 .Cells(ze, 1) = strFileName .Cells(ze, 2).PasteSpecial Paste:=xlPasteValues .Cells(ze, 3) = strSuchText1 .Cells(ze, 4) = strSuchText2 End With objWDApp.Activedocument.Close savechanges:=False objWDApp.Quit Exit Sub FBRoutine: MsgBox "Es ist ein Fehler ausgetreten. ErrorNummer = " & Err.Number, vbCritical + vbOKOnly, "Hinweis" End Sub

Sub getDocListe() Dim lngAnzahl As Long Dim strDatei As String Dim strDateien() As String Dim myPath As String Dim cTxt As String myPath = "C:\Users\joche\Desktop" 'Anpassen strDatei = Dir(myPath & "\*.doc*") 'Anpassen; nur *.doc ? oder auch *,docx ? Do While Len(strDatei) If strDatei ThisWorkbook.Name Then lngAnzahl = lngAnzahl + 1 ReDim Preserve strDateien(1 To lngAnzahl) strDateien(lngAnzahl) = strDatei Call Hole_Wordtexte(myPath, strDatei) End If strDatei = Dir Loop End Sub Sub Hole_Wordtexte(myPath, strDatei) Dim strFileName As String 'Pfad und Dateiname Dim objWDApp As Object 'Word Applikation Dim strSuchText1 As String 'Suchbegriff 1 = Anfang Dim strSuchText2 As String 'Suchbegriff 2 = Ende Dim ze As Long strFileName = myPath & "\" & strDatei strSuchText1 = "Verantwortlichkeiten / Aufgaben" strSuchText2 = "Kritische Erfolgsfaktoren / Messgrößen" On Error GoTo FBRoutine 'bei Fehler zur Fehlerbehandlung Set objWDApp = CreateObject("Word.Application") objWDApp.Visible = True objWDApp.documents.Open strFileName With objWDApp.Activedocument.Range If .Find.Execute(strSuchText1) Then vStart = .Start + 33 'ohne Suchbegriff, oder? (sonst -1) End With With objWDApp.Activedocument.Range If .Find.Execute(strSuchText2) Then vLast = .Start - 2 End With 'objWDApp.Activedocument.Range(Start:=vStart, End:=vLast).Copy cTxt = objWDApp.Activedocument.Range(Start:=vStart, End:=vLast) With Sheets("Tabelle1") ze = .Cells(Rows.Count, 2).End(xlUp).Row + 1 .Cells(ze, 1) = strFileName .Cells(ze, 2) = cTxt .Cells(ze, 3) = strSuchText1 .Cells(ze, 4) = strSuchText2 End With objWDApp.Activedocument.Close savechanges:=False objWDApp.Quit Exit Sub FBRoutine: MsgBox "Es ist ein Fehler ausgetreten. ErrorNummer = " & Err.Number, vbCritical + vbOKOnly, "Hinweis" End Sub

Sub getDocListe() Dim lngAnzahl As Long Dim strDatei As String Dim strDateien() As String Dim myPath As String Dim cTxt As String myPath = "C:\Temp\" 'Anpassen strDatei = Dir(myPath & "\*.doc*") 'Anpassen; nur *.doc ? oder auch *,docx ? Do While Len(strDatei) If strDatei ThisWorkbook.Name Then lngAnzahl = lngAnzahl + 1 ReDim Preserve strDateien(1 To lngAnzahl) strDateien(lngAnzahl) = strDatei Call Hole_Wordtexte(myPath, strDatei) End If strDatei = Dir Loop End Sub

Sub Hole_Wordtexte(myPath, strDatei) Dim strFileName As String 'Pfad und Dateiname Dim objWDApp As Object 'Word Applikation Dim strSuchText1 As String 'Suchbegriff 1 = Anfang Dim strSuchText2 As String 'Suchbegriff 2 = Ende Dim ze As Long strFileName = myPath & "\" & strDatei strSuchText1 = "Suchbegriff1" 'Anpassen! strSuchText2 = "Suchbegriff2" 'Anpassen! On Error GoTo FBRoutine 'bei Fehler zur Fehlerbehandlung Set objWDApp = CreateObject("Word.Application") objWDApp.Visible = True objWDApp.documents.Open strFileName With objWDApp.Activedocument.Range If .Find.Execute(strSuchText1) Then vStart = .Start + 33 'ohne Suchbegriff, oder? End With With objWDApp.Activedocument.Range If .Find.Execute(strSuchText2) Then vLast = .Start - 2 End With objWDApp.Activedocument.Range(Start:=vStart, End:=vLast).Copy With Sheets("Tabelle1") ze = .Cells(Rows.Count, 2).End(xlUp).Row + 1 .Cells(ze, 1) = strFileName .Cells(ze, 2).PasteSpecial Paste:=xlPasteValues .Cells(ze, 3) = strSuchText1 .Cells(ze, 4) = strSuchText2 End With objWDApp.Activedocument.Close savechanges:=False objWDApp.Quit Exit Sub FBRoutine: MsgBox "Es ist ein Fehler ausgetreten. ErrorNummer = " & Err.Number, vbCritical + vbOKOnly, "Hinweis" End Sub

hab' nochmal was probiert:


Option Explicit
Sub getDocListe()
Dim lngAnzahl As Long
Dim strDatei As String
Dim strDateien() As String
Dim myPath As String
myPath = "C:\Users\joche\Desktop"   'Anpassen!!
strDatei = Dir("Z:\Files" & "\*.doc*")    'Anpassen!!
Do While Len(strDatei)
If strDatei  ThisWorkbook.Name Then
lngAnzahl = lngAnzahl + 1
ReDim Preserve strDateien(1 To lngAnzahl)
strDateien(lngAnzahl) = strDatei
'Debug.Print strDatei
Call Hole_Wordtexte(myPath, strDatei)
End If
strDatei = Dir
Loop
End Sub
Sub Hole_Wordtexte(myPath, strDatei)
Dim strFileName As String     'Pfad und Dateiname
Dim objWDApp As Object        'Word Applikation
Dim strSuchText1 As String    'Suchbegriff 1 = Anfang
Dim strSuchText2 As String    'Suchbegriff 2 = Ende
Dim strCtxt As String         'kopierter Text aus Worddatei
Dim numLänge As Long          'Länge des Textes
Dim numZe As Long             'Schleifenzähler
Dim numZeile As Long          'Schleifenzähler
Dim numSchleifenzähler        'Schleifenzähler
Dim strSplitArray As Variant  'Array für den getrennten Wordtext
Dim strVStart As Long         'Position Start Textteil
Dim strVLast As Long          'Position Ende Textteil
'Pfad-/Dateiname in VAriable übergeben
strFileName = myPath & "\" & strDatei
'die beiden Suchbegriffe in Variable übergeben
strSuchText1 = "Verantwortlichkeiten / Aufgaben"
strSuchText2 = "Kritische Erfolgsfaktoren / Messgrößen"
'Fehlerroutine vorbereiten
On Error GoTo FBRoutine
'Word-App starten und sichtbar machen
Set objWDApp = CreateObject("Word.Application")
objWDApp.Visible = True
'Word-Dokument öffnen
objWDApp.documents.Open strFileName
'die Position für den Start des auszuschneidenden Text ermitteln
With objWDApp.Activedocument.Range
If .Find.Execute(strSuchText1) Then strVStart = .Start + 34 '34 um  den Suchbegriff nicht mitkopieren
End With
'die Position für das Ende des auszuschneidenden Textes ermitteln
With objWDApp.Activedocument.Range
If .Find.Execute(strSuchText2) Then strVLast = .Start - 4
End With
'den Textschnipsel anhand der beiden Positionen in VAriable übergeben
strCtxt = objWDApp.Activedocument.Range(Start:=strVStart, End:=strVLast)
'Word-Datei und Word-App wieder schließen
objWDApp.Activedocument.Close savechanges:=False
objWDApp.Quit
'überflüssige Leerzeichen aus dem String entferne
strCtxt = Trim(strCtxt)
'Anzahl der Zeichen des Strings in VAriable übergeben
numLänge = Len(strCtxt)
'den Strin zerlegen anhand Textxtrennee chr(13) "Zeilenumbruch"
strSplitArray = Split(strCtxt, Chr(13))
'ab hier werden die Daten in die Tabelle geschrieben
With Sheets("Tabelle1")
'ermitteln in welcher Zeile der nächste Eintrag beginnt
numZe = .Cells(Rows.Count, 2).End(xlUp).Row + 1
.Cells(numZe, 1) = strFileName
'der mit Split-Befehl zerteilte Text in jeweils eine Zeile schreiben
For numZeile = numZe To numZe + UBound(strSplitArray)
'.Cells(numZeile, 1) = strFileName 'braucht man das in jeder Zeile?
.Cells(numZeile, 2) = strSplitArray(numSchleifenzähler)
numSchleifenzähler = numSchleifenzähler + 1
Next
.Cells(numZe, 3) = strSuchText1
.Cells(numZe, 4) = strSuchText2
End With
'Fertig und Beenden
Exit Sub
FBRoutine:
objWDApp.Activedocument.Close savechanges:=False
objWDApp.Quit
MsgBox "Es ist ein Fehler ausgetreten. ErrorNummer = " & Err.Number, vbCritical + vbOKOnly, "Hinweis"
End Sub

Gruß
Jochen

Beliebteste Forumthreads (12 Monate)

Bestimmte_Zeilen_aus_WordDatei_auslesen

23 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread