Hallo liebe Community,
nachdem ich seit einigen Tagen nicht weiterkomme, wende ich mcih an euch.
Hintergrund:
Ich möchte ein automatisiertes Such-Kopier-Tool basteln, welches mehrere Wörter (siehe Datei, alle Wörter ab Spalte C15) nacheinander in Word sucht und falls es findet, einen Textausschnitt in Excel einfügt.
Ziel:
Pro Bereicht habe ich einen Reiter mit dem gefundenen Text und weitere Informationen. Er soll nur nach ganzen Worten suchen, nicht auf Klein- und Großschreibung achten und wenn es geht Punktuation (und am liebsten Leerzeichen) ignorieren.
Beispiel für Suchwort: "Richtig"
Folgende Wörter soll der Code beachten: "richtig", "Richtig", "Richtig.", "RICHTIG!", ("r i c h t i g")
Folgende Wörter soll der Coden NICHT beachten: "richtige", "Richtigstellung"
Jetziger Stand und Problem:
Alles klappt, bis auf dass die Suchfunktion kaum akkurat ist. Bedeutet, dass der Code manche Wörter nicht findet und folglich nciht rauskopiert, die in der Word Datei enhalten sind. Ich habe mich auch mit der Einstellung der zahlreichen Funktionen von Find.Execute auseinander gesetzt. Jedoch bin ich am verzweifeln. Ich kann nicht erkennen, ob es an den Einstellungen der Funktionen liegt, dass er mehrere Wörter sind oder irgendetwas mit der Schleife falsch ist.
Über jeden Tip freue ich mich sehr. Anbei die Datei und ein Beispielsdokument.
Dateien:
Code:
Sub Kopieren_von_Sinnabschnitten()
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
Dim CurrRowShtSearchItem As Long
Dim CurrRowShtExtract As Long
Dim myPara As Long
Dim myLine As Long
Dim myPage As Long
Dim oDocName As Variant
Dim ncharacterbefore As Variant
Dim ncharacterafter As Variant
Dim xRange_searchterm As Range
Dim xRange_searchterm2 As Range
Dim LetzteG As Integer
Dim LetzteSearch As Integer
Dim Namee As Variant
Dim NameSheet As Variant
Dim i As Integer
Dim y As Integer
Dim a As Integer
Dim r As Long
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
dataPath = Worksheets("Cockpit").Cells(5, 3).Value '<= modify according to your path
dataFile = Dir(dataPath & "*.docx")
'--------Repeating Tesks for each Docucument ´begins here ------------------------------------------
Do While dataFile <> vbNullString
Set oDoc = oWord.Documents.Open(dataPath & dataFile)
oDocName = oWord.ActiveDocument.Name
Set shtSearchItem = ThisWorkbook.Worksheets("Cockpit")
If ThisWorkbook.Worksheets.Count < 2 Then
ThisWorkbook.Worksheets.Add After:=shtSearchItem
End If
Set shtExtract = ThisWorkbook.Worksheets(2)
ThisWorkbook.Worksheets(2).Cells.ClearContents
LastRow = shtSearchItem.UsedRange.Rows(shtSearchItem.UsedRange.Rows.Count).Row
Namee = oDocName
ThisWorkbook.Worksheets(1).Cells(12, 3) = Namee
ncharacterbefore = ThisWorkbook.Worksheets(1).Cells(8, 4)
ncharacterafter = ThisWorkbook.Worksheets(1).Cells(9, 4) ' Sheet: Cockpit; Column: Characters
NameSheet = Trim$(Left$(Worksheets("Cockpit").Cells(12, 3).Value, InStr(Worksheets("Cockpit").Cells(12, 3).Value, " ") + 1))
shtExtract.Cells(1, 1).Value = "Suchbegriff"
shtExtract.Cells(1, 2).Value = "Seite"
shtExtract.Cells(1, 3).Value = "Berichtsname"
shtExtract.Cells(1, 4).Value = "Ergebnisse"
For CurrRowShtSearchItem = 15 To LastRow
CurrRowShtExtract = 1
Set oRange = oDoc.Range
With oRange.Find
.Text = shtSearchItem.Cells(CurrRowShtSearchItem, 3).Text
.MatchCase = False
.MatchWholeWord = True
'.IgnorePunct = True
'.IgnoreSpace = True
'.MatchWildcards = False
'.MatchSoundsLike = False
'.MatchAllWordForms = False
'.Wrap = wdFindStop
While .Execute = True
myPara = oDoc.Range(0, oRange.End).Paragraphs.Count
myPage = oRange.Information(wdActiveEndAdjustedPageNumber)
myLine = oRange.Information(wdFirstCharacterLineNumber)
oRange.MoveStart wdCharacter, -ncharacterbefore
oRange.MoveEnd wdCharacter, ncharacterafter
CurrRowShtExtract = CurrRowShtExtract + 1
shtExtract.Cells(CurrRowShtExtract, 1).Value = .Text
shtExtract.Cells(CurrRowShtExtract, 2).Value = myPage
shtExtract.Cells(CurrRowShtExtract, 3).Value = oDocName
shtExtract.Cells(CurrRowShtExtract, 4) = oRange.Text
'shtExtract.Cells(CurrRowShtExtract, 1).Value = .Text
'shtExtract.Cells(CurrRowShtExtract, 2).Value = myPara
'shtExtract.Cells(CurrRowShtExtract, 3).Value = myPage
'shtExtract.Cells(CurrRowShtExtract, 4).Value = myLine
'shtExtract.Cells(CurrRowShtExtract, 5).Value = oDocName
'shtExtract.Cells(CurrRowShtExtract, 6) = oRange.Text
oRange.MoveStart wdCharacter, ncharacterafter
oRange.MoveEnd wdCharacter, ncharacterbefore
oRange.Collapse wdCollapseEnd
Wend
End With
Next CurrRowShtSearchItem
'-----------Prepare settings for Sheet Findings (listed)-------------
shtExtract.Range("A1:D1").AutoFilter
ActiveWorkbook.Worksheets("Findings (listed)").AutoFilter.Sort.SortFields.Add2 Key:= _
Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Findings (listed)").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("Findings (listed)").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = NameSheet
'------- VLookUp for Searchwords
With Sheets("Cockpit")
LetzteSearch = Worksheets("Cockpit").Cells(Rows.Count, 3).End(xlUp).Row + 1
LetzteName = Worksheets("Cockpit").Cells(Rows.Count, 6).End(xlUp).Row + 1
Anzahlsearch = LetzteSearch - 15
Rangecomp = LetzteName + Anzahlsearch
End With
a = 15
Do Until a = LetzteSearch
If IsEmpty(Worksheets("Cockpit").Cells(a, 3)) = False Then
Worksheets("Cockpit").Cells(a, 4) = Application.WorksheetFunction.CountIf(Worksheets("Findings (listed)").Range("A:A"), Worksheets("Cockpit").Cells(a, 3))
End If
a = a + 1
Loop
i = LetzteName
y = 15
r = Sheets.Count
Do Until i = Rangecomp
If Worksheets("Cockpit").Cells(i, 6).Borders(xlEdgeBottom).LineStyle <> xlNone Then
Worksheets("Cockpit").Rows(i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
End If
Worksheets("Cockpit").Cells(i, 6).Value = Worksheets("Cockpit").Cells(12, 3).Value
Worksheets("Cockpit").Cells(i, 7).Value = Worksheets("Cockpit").Cells(y, 3).Value
Worksheets("Cockpit").Cells(i, 8).Value = Worksheets("Cockpit").Cells(y, 4).Value
y = y + 1
i = i + 1
Loop
Application.CutCopyMode = False
ActiveDocument.Close _
dataFile = Dir
Loop
Worksheets("Cockpit").Cells(1, 1).Value = LastRow
If WordNotOpen Then
oWord.Quit
End If
Set oWord = Nothing
Set oDoc = Nothing
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
If WordNotOpen Then
End If
oWord.Quit
Worksheets("Cockpit").Cells(12, 3).Select
End Sub
|