.txt: Wort suchen und Satz nach Excel übermitteln

Hallo,
ich habe folgendes Problem.
Ich habe einen riesengroßen .txt Datei mit nur unstrukturierten Text. In dieser Text möchte ich nach ein bestimmtes Wort suchen und das Makro soll dann der Satz in dem das Wort steht (also das was zwischen "." und "." steht zurückgeben.
Wie ich ein bestimmten String finde und nach Excel übermittele krieg ich einigermaßen hin. Die Frage is bloß wie bekomme ich es hin, dass ich den ganzen Satz finde?
Um es zu veranschaulichen ein kleines Beispiel:
Inhalt .txt Datei:
Das Haus ist grün. Das Auto ist blau. Bla bla bla...
Gesucht wird "Auto", das Makro soll dann "Das Auto ist blau." (und alle weitere Sätze mit "Auto") in eine Excel Tabelle schreiben.
Danke für alle Tipps im voraus!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo ?
probier mal.
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

'Nach einer Idee von http://www.activevb.de
'Angepasst von J.Ehrensberger

Option Explicit

Sub sucheInTextFile()
Dim x As Long, Zeilen() As String, FName As String, sText As String

On Error GoTo ERRORHANDLER
Application.ScreenUpdating = False

FName = Application.GetOpenFilename("Text Dateien (*.txt)," & _
    "*.txt")

If FName = "Falsch" Then GoTo ERRORHANDLER

sText = InputBox("Bitte Suchtext eingeben", "Suche", "") 'Suchtext

If sText = "" Then Exit Sub

Range("A:A").ClearContents 'Datenbereich löschen

'Die letzten beiden Parameter geben das linke und rechte
'Begrenzungszeichen einer Zeile an, dies können auch
'mehrere sein. Hier wurde für links und rechts "D" gewählt!
If FindTerm(FName, sText, Zeilen, ".", ".") Then

    For x = 0 To UBound(Zeilen) - 1
        Cells(x + 1, 1) = Trim$(Zeilen(x))
    Next

    MsgBox "Es wurden " & UBound(Zeilen) & " Zeilen gefunden!"

Else
    MsgBox "Suchbegriff nicht vorhanden!"
End If

ERRORHANDLER:
If Err.Number > 0 Then
    MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Fehler"
End If
Application.ScreenUpdating = True
End Sub

Private Function FindTerm(File As String, s As String, ZZ() As String, _
    tl As String, tr As String) As Boolean

Dim c As Long, i As Long, j As Long
Dim FLen As Long, lc As Long, p As Long
Dim v As Long, w As Long
Dim f As Integer
Dim a As String, d As String
Dim buffer As String, old As String

'Dieser Wert gibt die Paketgröße von Get# an. Er kann beliebig
'geändert werden, sollte aber nicht kleiner als die längste
'zu erwartende Zeile des zu druchsuchenden Files sein
Const PS As Long = 1024&

Redim ZZ(0)

'Prüfen ob Parameter plausibel sind
If Len(tl) = 0 Or Len(tr) = 0 Or Len(s) = 0 Or _
    Dir$(File, vbNormal) = "" Then

    MsgBox ("Paramter stimmen nicht!")
    Exit Function
End If

s = LCase(s)

f = FreeFile
Open File For Binary Shared As #f
FLen = LOF(f)

'Anzahl der Durchläufe anhand der Dateigröße ermitteln
p = FLen \ PS
If FLen Mod PS <> 0 Then p = p + 1

'Schleife starten
For c = 1 To p
    buffer = Space$(PS)
    Get f, , buffer
    a = old & buffer

    i = InStr(1, LCase(a), s)
    If i <> 0 Then
        'Suchbegriff wurde im aktuellen Paket gefunden
        lc = 0
        Do
            i = InStr(i, LCase(a), s)
            If i <> 0 Then

                'Zeilenanfang suchen
                v = 1
                For j = i To 1 Step -1
                    d = Mid$(a, j, 1)

                    'gefunden
                    If InStr(1, tl, d) Then
                        v = j + 1
                        Exit For
                    End If
                Next j

                'Zeilenende suchen
                w = 0
                For j = i To Len(a)
                    d = Mid$(a, j, 1)

                    'gefunden
                    If InStr(1, tr, d) Then
                        w = j
                        Exit For
                    End If
                Next j

                If w <> 0 Then
                    ' Zeile auschneiden und in einem Feld speichern
                    ' Hier könnten auch weitere Suchkriterien abge-
                    ' fragt werden.
                    ZZ(UBound(ZZ)) = Mid$(a, v, w - v)
                    Redim Preserve ZZ(0 To UBound(ZZ) + 1)
                    lc = w
                End If

                i = w
            End If

            'Weiter schleifen, da der Suchbegriff im Paket ja
            'öfters als einmal auftauchen kann
        Loop Until i = 0

        If lc = 0 Then
            'Suchbegriff wurde im aktuellen Paket nicht ge-
            'funden. Daher ganzen String für die nächste Runde
            'speichern
            old = a
        Else
            'Ab Ende der zuletzt gefundenen Zeile des aktuel-
            'len Paketes für die nächste Runde speichern
            old = Mid$(a, lc)
        End If
    Else
        'Paket der aktuellen Runde speichern
        old = buffer
    End If
Next c
Close f

If UBound(ZZ) > 0 Then FindTerm = True
End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

.txt: Wort suchen und Satz nach Excel übermitteln

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

.txt: Wort suchen und Satz nach Excel übermitteln

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread