Text von Word nach Excel auf Basis von Suchwörtern kopieren

Hallo liebe Forumsmitglieder,
im Rahmen einer Research-Arbeit für meine Abschlussarbeit muss ich auf Basis von Schlagwörtern Textstellen von Worddokumenten in eine Exceldatei übertragen.
Es handelt sich um eine Liste von Schlagwörtern (alle in einer Excelspalte untereinander aufgelistet) und um mehre Worddokumente (ca. 80-100 mit jeweils 400 Seiten).
Das Programm soll das Worddokument nach den Schlagwörtern durchsuchen und falls ein Wort gefunden wird, soll das entsprechende Wort + 350 Zeichen vor und nach dem Wort in eine Excelzeile kopieren. Zusätzlich sollen der Name des Dokuments und die Seitenzahl übernommen werden. Jede Fundstelle soll in eine neue Zeile kopiert werden.
Auf Basis erster Recherchen bei Google habe ich folgenden Code erhalten. Mit dem Code funktioniert schon das meiste. Jedoch fehlt die Abarbeitung aller Dokumente in einer Schleife.
Bei dem Versuch die Schleife zu bauen komme ich leider nicht weiter. Habt ihr eine Idee / Lösung dafür?
Des weiteren schaffe ich es noch nicht die 350 Zeichen vor und nach dem Suchwort zu kopieren. Über Ideen / Lösungsvorschläge würde ich mich sehr freuen.
Funktionierender Code (von www.exceltrainingvideos.com)


Sub LocateSearchItem()
Dim shtSearchItem As Worksheet
Dim shtExtract As Worksheet
Dim oWord As Word.Application
Dim WordNotOpen As Boolean
Dim oDoc As Word.Document
Dim oRange As Word.Range
Dim LastRow As Long                 ' last row with data in shtSearchItem
Dim CurrRowShtSearchItem As Long    ' current row in shtSearchItem
Dim CurrRowShtExtract As Long       ' current row in shtExtract
Dim myPara As Long
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
If Err Then
Set oWord = New Word.Application
WordNotOpen = True
End If
On Error GoTo Err_Handler
oWord.Visible = True
oWord.Activate
Set oDoc = oWord.Documents.Open("C:\Users\Lenovo\Downloads\Data fronm Word to Excel\ _
Testdatei.docx")       '

Idee für die Schleife zur Abarbeitung aller Worddokumente:
Sub Schleife()
Dim sPfad As String
Dim sDatei As String
Dim oDocument As Object
Application.ScreenUpdating = False
sPfad = "C:\TEST\Sammlung\"
sDatei = Dir(CStr(sPfad & "*.do*")) 'Alle Word Dateien im Verzeichnis
Do While sDatei ""
Set oDocument = Documents.Open(sPfad & sDatei, , False)
........ .......
'die nächste Datei bitte...
sDatei = Dir()
Loop
Set oDocument = Nothing
Application.ScreenUpdating = True
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Fennek,
im Rahmen meiner Arbeit bewerte ich u.a. Textstelllen in Geschäftsberichten von Unternehmen indem ich auf Basis von Suchwörtern Stellen ausfindig mache, den Sinnabschnitt kopiere und anschließend nach festgelegten Kriterien bewerte. Die Bewertungen werden dann für die anderen Teile der Arbeit benötigt.
Falls du mir mit der Schleife und dem Kopieren von 350 Zeichen vor und nach dem Suchwort helfen kannst wäre ein Traum. Leider bin ich, trotz einiger Versuche und eigentlich auch ganz guten Beschreibungen im Internet nicht weiter gekommen.
Der Link zur Exceldatei mit dem aktuellen Code ist angehängt. Die Word Vorlage konnte ich aufgrund des Dateiformats (docx) nicht hochladen.
https://www.herber.de/bbs/user/134617.xlsm

Const Pfad As String = "c:\temp\" '>>> Sub F_en() Application.EnableCancelKey = xlInterrupt Dim WD As Object: Set WD = CreateObject("Word.Application") Dim Doc As Object WD.Visible = False lr = Cells(Rows.Count, 1).End(xlUp).Row Ar = Range("A1:A" & lr) j = 1 'Schleife über alle Wd-Dateien f = Dir(Pfad & "Aaron?.docm") ' vbNullString j = j + 1 Cells(1, j) = f Set Doc = WD.documents.Open(Pfad & f) For i = 2 To UBound(Ar) With Doc.Content.Find .Execute Ar(i, 1) If .Found Then Set Rng = .Parent Rng.SetRange Rng.Start - 10, Rng.End + 10 '.Parent.Expand unit:=wdParagraph Cells(i, j) = Rng End If End With Next i Doc.Close 0 f = Dir Loop WD.Quit End Sub

Sub LocateSearchItem_Test220() Dim shtSearchItem As Worksheet Dim shtExtract As Worksheet Dim oWord As Word.Application Dim WordNotOpen As Boolean Dim oDoc As Word.Document Dim oRange As Word.Range Dim LastRow As Long ' last row with data in shtSearchItem Dim CurrRowShtSearchItem As Long ' current row in shtSearchItem Dim CurrRowShtExtract As Long ' current row in shtExtract Dim myPara As Long Dim myLine As Long Dim myPage As Long Dim oDocName As Variant On Error Resume Next Application.ScreenUpdating = False Set oWord = GetObject(, "Word.Application") If Err Then Set oWord = New Word.Application WordNotOpen = True End If On Error GoTo Err_Handler oWord.Visible = True oWord.Activate Set oDoc = oWord.Documents.Open("C:\Users\Lenovo\Downloads\Data fronm Word to Excel\ _ Testdatei.docx") '

Sub LocateSearchItem_Test220() Dim shtSearchItem As Worksheet Dim shtExtract As Worksheet Dim oWord As Word.Application Dim WordNotOpen As Boolean Dim oDoc As Word.Document Dim oRange As Word.Range Dim LastRow As Long ' last row with data in shtSearchItem Dim CurrRowShtSearchItem As Long ' current row in shtSearchItem Dim CurrRowShtExtract As Long ' current row in shtExtract Dim myPara As Long Dim myLine As Long Dim myPage As Long Dim oDocName As Variant On Error Resume Next Application.ScreenUpdating = False Set oWord = GetObject(, "Word.Application") If Err Then Set oWord = New Word.Application WordNotOpen = True End If On Error GoTo Err_Handler oWord.Visible = True oWord.Activate '####################### neu sPfad = "c:\Test\Sammlung\" sFile = dir(sPfad & "*.docx") '#### Set oDoc = oWord.Documents.Open("C:\Users\Lenovo\Downloads\Data fronm Word to Excel\ _ Testdatei.docx") ' vbnullstring Set oDoc = oWord.Documents.Open(sPfad & sFile) oDocName = ActiveDocument.Name Set shtSearchItem = ThisWorkbook.Worksheets(1) If ThisWorkbook.Worksheets.Count

Beliebteste Forumthreads (12 Monate)

Text von Word nach Excel auf Basis von Suchwörtern kopieren

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

272 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Text von Word nach Excel auf Basis von Suchwörtern kopieren

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

272 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread