die Nadel im Heuhaufen suchen...

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Michael!
Ich hab' dein Testfile mal auf 5.500 KB aufgebläht und der Code läuft Tadellos!
Die Umbrüche werden jetzt entfernt und auch die letzte Ziffer wird nicht mehr verschluckt.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

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

On Error GoTo ERRORHANDLER

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

If FName = "Falsch" Then Exit Sub

sText = "G3MP2=" 'Suchtext

If sText = "" Then Exit Sub

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .DisplayAlerts = False
  .Calculation = xlCalculationManual
  .Cursor = xlWait
End With

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.
If FindTerm(FName, sText, Zeilen, "\", "\") Then

  For x = 0 To UBound(Zeilen) - 1

    Cells(x + 1, 1) = Zeilen(x)

  Next x

  MsgBox "Es wurde" & IIf(UBound(Zeilen) > 1, "n ", " ") & UBound(Zeilen) & _
    " Zeile" & IIf(UBound(Zeilen) > 1, "n ", " ") & "gefunden!"

Else
  MsgBox "Suchbegriff nicht vorhanden!"
End If

ERRORHANDLER:
Debug.Print Err.Number; Err.Description
With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
  .Cursor = xlDefault
End With

End Sub

Private Function FindTerm(File As String, s As String, ZZ() As String, _
  tl As String, tr As String) As Boolean
'Nach einer Idee von http://www.activevb.de
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

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
  a = Replace(Replace(a, Chr(10), ""), Chr(13), "") 'Zeilenumbrüche entfernen

  i = InStr(1, a, s)
  If i <> 0 Then
    'Suchbegriff wurde im aktuellen Paket gefunden
    lc = 0
    Do
      i = InStr(i, 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
'*
'* Rückmeldung wäre nett!
'******************************

Hallo Michael!
...klappts auch mit Umbruch im Suchbegriff!

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

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

'On Error GoTo ERRORHANDLER

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

If FName = "Falsch" Then Exit Sub

sText = "G3MP2=" 'Suchtext

If sText = "" Then Exit Sub

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .DisplayAlerts = False
  .Calculation = xlCalculationManual
  .Cursor = xlWait
End With

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.
If FindTerm(FName, sText, Zeilen, "\", "\") Then

  For x = 0 To UBound(Zeilen) - 1

    Cells(x + 1, 1) = Zeilen(x)
    'Oder nur den Wert
    Cells(x + 1, 1) = CDbl(Trim$(Replace(Replace(Replace(Zeilen(x), sText, ""), ".", ","), " ", "")))

  Next x

  MsgBox "Es wurde" & IIf(UBound(Zeilen) > 1, "n ", " ") & UBound(Zeilen) & _
    " Zeile" & IIf(UBound(Zeilen) > 1, "n ", " ") & "gefunden!"

Else
  MsgBox "Suchbegriff nicht vorhanden!"
End If

ERRORHANDLER:
Debug.Print Err.Number; Err.Description
With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
  .Cursor = xlDefault
End With

End Sub

Private Function FindTerm(File As String, s As String, ZZ() As String, _
  tl As String, tr As String) As Boolean
'Nach einer Idee von http://www.activevb.de
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

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
  a = Replace(Replace(Replace(a, Chr(10), ""), Chr(13), ""), " ", "") 'Zeilenumbrüche entfernen

  i = InStr(1, a, s)
  If i <> 0 Then
    'Suchbegriff wurde im aktuellen Paket gefunden
    lc = 0
    Do
      i = InStr(i, 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
'*
'* Rückmeldung wäre nett!
'******************************

Sub Suche_spezial2() Dim intFile%, Zeile1$, Zeile2$, FName$, sText1$, sText2$, sText3$ Dim nrRec&, zz&, ss%, pp%, qq% FName = "f:\exc\w-w-w\tmp\SuchText.txt" sText1 = "Diagonal vibrational polarizability" 'Suchtext1 sText2 = "\G3MP2=" 'Suchtext2 sText3 = "\" 'Suchtext3 Range("A:Z").ClearContents 'Datenbereich löschen zz = 1 Cells(1, 1) = "Rec" Cells(1, 2) = "gefunden" intFile = FreeFile(1) Open FName For Binary As #intFile Do Until EOF(intFile) nrRec = nrRec + 1: Line Input #intFile, Zeile1 If InStr(Zeile1, sText1) > 0 Then zz = zz + 1 Cells(zz, 1) = nrRec Cells(zz, 2) = sText1 End If Loop Close intFile zz = zz + 1 Cells(zz, 1) = nrRec Cells(zz, 2) = "(Anzahl Sätze)" Open FName For Binary As #intFile nrRec = 0 zz = 2 nrRec = nrRec + 1: Line Input #intFile, Zeile1 Do Until EOF(intFile) nrRec = nrRec + 1: Line Input #intFile, Zeile2 Zeile2 = LTrim(Zeile2) ' Leerzeichen links killen pp = InStr(Zeile1 & Zeile2, sText2) While pp > 0 And pp <= Len(Zeile1) ' statt <= 70 qq = InStr(pp + Len(sText2), Zeile1 & Zeile2, sText3) While Cells(zz + 1, 1) < nrRec zz = zz + 1 Wend Rows(zz + 1).Insert zz = zz + 1 Cells(zz, 1) = nrRec - 1 Cells(zz, 2) = _ Mid(Zeile1 & Zeile2, pp + Len(sText2), qq - pp - Len(sText2)) pp = InStr(qq, Zeile1 & Zeile2, sText2) Wend Zeile1 = Zeile2 Loop Close intFile End Sub

Beliebteste Forumthreads (12 Monate)

26 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread