Makro umgestalten
29.11.2020 12:08:20
stef26
ich habe letzte Woche hier im Forum vom Matthias ein super Makro gebaut bekommen, welches mir aus 15.000 Word Dokumente 3 bestimmte Suchkriterien sucht und die ganze Zeile in der sich das Word befindet in Excel auflistet.
Nochmal recht herzlichen Dank dafür, das hat mir Wochenlanges suchen erleichtert. DANKE Matthias.
Nun habe ich einen ähnliche Fall, den ich mit dem Makro (welches für 3 Suchwörter bis zu 10h läuft leider so nicht benutzen kann. D. h. das Makro müsste nochmal etwas anders zusammengestellt werden.
Ich habe nun in der Spalte A die Datei in der gesucht werden soll.
In Spalte B bis Spalte AI stehen zur jeweiligen Datei die Suchwörter (33 Stück) die gesucht werden sollen.
Nun meine erneute unverschämte Bitte. Wer ist in der Lage das Makro so umzustricken, dass die 33Suchwörter der jeweiligen Datei gesucht werden, und würde das nochmal für mich für versuchen anzupassen?
Anbei das aktuelle Makro, was der Matthias so super erstellt hat:
Sub WordSuchExtraZeileViel()
Dim inhalt As Variant
Dim pfad, datnamem, kriterien(1 To 3)
Dim treffer(), fertig()
Dim temp
Dim zeile As Long, anzzeil As Long, krit As Long, spalte As Long
Dim startp As Long, endp As Long, nextp As Long
Dim erster As Boolean
Sheets("Suche-Word-Zeilen").Range("D1").Value = Now
On Error GoTo fehler
pfad = ActiveWorkbook.Path & "\"
datname = Dir(pfad & "*.doc*")
ReDim Preserve treffer(1 To 4, 1 To 2)
treffer(1, 1) = "Trefferübersicht"
kriterien(1) = ActiveWorkbook.ActiveSheet.Range("C1")
kriterien(2) = ActiveWorkbook.ActiveSheet.Range("E1")
kriterien(3) = ActiveWorkbook.ActiveSheet.Range("G1")
treffer(1, 2) = "Dateiname"
treffer(2, 2) = kriterien(1)
treffer(3, 2) = kriterien(2)
treffer(4, 2) = kriterien(3)
anzzeil = 2
erster = True
Do Until datname = ""
With GetObject(pfad & datname)
inhalt = .Content
.Close SaveChanges:=False
End With
'Inhalt nach Zeilen aufsplitten
temp = Split(inhalt, Chr(13))
anzzeil = anzzeil + 1
startp = anzzeil
endp = startp
ReDim Preserve treffer(1 To 4, 1 To anzzeil)
treffer(1, anzzeil) = datname
For krit = 1 To 3
If kriterien(krit) "" Then
If InStr(1, inhalt, kriterien(krit), vbTextCompare) > 0 Then
nextp = startp
For zeile = 0 To UBound(temp)
If InStr(1, temp(zeile), kriterien(krit), vbTextCompare) > 0 Then
If nextp endp Then endp = nextp - 1
Else
treffer(krit + 1, startp) = "kein Treffer"
End If
End If
Next
datname = Dir
Loop
ReDim fertig(1 To UBound(treffer, 2), 1 To 4)
For zeile = 1 To 4
For spalte = 1 To UBound(treffer, 2)
fertig(spalte, zeile) = treffer(zeile, spalte)
Next spalte
Next zeile
Cells(2, 1).Resize(UBound(treffer, 2), 4) = fertig
Sheets("Suche-Word-Zeilen").Range("F1").Value = Now
Exit Sub
fehler:
MsgBox "Irgendwas ist schief gelaufen!"
End Sub
Liebe Gruesse
Stefan