Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim pos As Long
Dim rs2 As DAO.Recordset
Dim sFound() As String
Dim nCount As Integer
 
Open "C:Vorlagen.txt" For Output As 1
 
Set db = CurrentDb
Set rs = db.OpenRecordset("TextReadIn")
 
' Tabelle mit den Unterkategorien öffnen
Set rs2 = db.OpenRecordset("U_kat_BeraterALT")
 
Do Until rs.EOF
  rs2.MoveFirst
  nCount = 0
  ReDim sFound(0) As String
 
  Do Until rs2.EOF
    pos = InStr(rs("TextRead"), rs2("Uk_Name_Berater"))
    If pos > 0 Then  ' Vergleich erfolgreich
      nCount = nCount + 1
      ReDim Preserve sFound(nCount)
      sFound(nCount) = rs2("Uk_Name_Berater")
    End If
    rs2.MoveNext
   Loop
 
    ' Alle Fundstellen in einer ListBox ausgeben
    For I = 1 To nCount
      MsgBox "Gefunden: " & sFound(I)
      Print #1, sFound(I)
    Next I
 
  rs.MoveNext
Loop
 
rs2.Close: Set rs2 = Nothing
rs.Close: Set rs = Nothing
Set db = Nothing
MsgBox "Erlädscht"