AW: link zur ursprünglichen Frage
25.11.2020 21:36:02
Matthias
Moin!
Wie versprochen hier die Versionen.
1. Variante (alles in einer Zelle):
Sub M_snb()
Dim inhalt As Variant
Dim pfad, datnamem, kriterien(1 To 3)
Dim treffer(), fertig()
Dim temp
Dim zeile As Long, anzdat As Long, krit As Long, spalte As Long
On Error GoTo XL90:
pfad = ActiveWorkbook.Path & "\"
datname = Dir(pfad & "*.docx")
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)
anzdat = 0
Do Until datname = ""
With GetObject(pfad & datname)
inhalt = .Content
.Close -1
End With
'Inhalt nach Zeilen aufsplitten
temp = Split(inhalt, Chr(13))
anzdat = anzdat + 1
ReDim Preserve treffer(1 To 4, 1 To anzdat + 2)
treffer(1, anzdat + 2) = datname
For krit = 1 To 3
If kriterien(krit) "" Then
If InStr(1, inhalt, kriterien(krit), vbTextCompare) > 0 Then
For zeile = 0 To UBound(temp)
If InStr(1, temp(zeile), kriterien(krit), vbTextCompare) > 0 Then
treffer(krit + 1, anzdat + 2) = treffer(krit + 1, anzdat + 2) & vbCrLf & _
" Zeile: " & zeile + 1 & " : " & temp(zeile)
End If
Next
Else
treffer(krit + 1, anzdat + 2) = "kein Treffer"
End If
End If
Next
datname = Dir
Loop
XL90:
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
End Sub
2. Variante (jeder Eintrag eine Zeile - sollte zumindest so sein :-) )
Sub M_snb()
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
On Error GoTo fehler
pfad = ActiveWorkbook.Path & "\"
datname = Dir(pfad & "*.docx")
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 -1
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
MsgBox "Fertig"
Exit Sub
fehler:
MsgBox "Irgendwas ist schief gelaufen!"
End Sub
Die zweite Variante bitte mal testen.
Ggf. könnte man an der laufzeit noch was ändern. Bspw. erstellt die getobject immer eine Instanz von word und scließt die wieder. Da könnte es ggf. kürzer sein, Word offen zu lassen und nur die Dateien zu öffnen. Ist aber nur eine Theorie.
VG