Makro anpassen

Sub DateinamenAuflisten()
Dim Dateiname As String, i As Integer
Dateiname = Dir$("C:\xxxxxx\Arbeitspläne\*.do*") 'Hier Verzeichnis und Datei angeben
Do While Dateiname  ""
ActiveCell.Offset(i, 0) = Dateiname
i = i + 1
Dateiname = Dir$()
Loop
End Sub

Sub WordSucheZeile()
Dim inhalt As Variant
Dim pfad, datnamem, kriterien(1 To 3)
Dim treffer()
Dim temp
Dim zeile As Long, anzdat As Long, krit As Long
On Error GoTo XL90:
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)
anzdat = 0
Do Until datname = ""
With GetObject(pfad & datname)
inhalt = .Content
.Close SaveChanges:=False
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 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
Next
datname = Dir
Loop
SXL90:
Cells(2, 1).Resize(UBound(treffer, 2), 4) = Application.Transpose(treffer)
End Sub