Schwierige Übernahme einer txt Datei in Excel

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Maurice!
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
Dim s1 As String, s2 As String

On Error GoTo ERRORHANDLER

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

If FName = "Falsch" Then Exit Sub

sText = "###"

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

Range("A:B").Clear '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 "***" gewählt!
If FindTerm(FName, sText, Zeilen, "***", "***") Then

  For x = 0 To UBound(Zeilen) - 1

    s1 = Left(Zeilen(x), InStr(1, Zeilen(x), "###") - 1)
    s2 = Mid(Zeilen(x), InStr(1, Zeilen(x), "###") + 3, 32767)

    Cells(x + 1, 1) = Replace(s1, Chr(13), "")
    Cells(x + 1, 2) = Replace(s2, Chr(13), Chr(10))

  Next x
  Rows("1:" & x).AutoFit
  Columns("A:B").AutoFit
  Columns("A:B").Cells.WrapText = True
  MsgBox "Es wurden " & UBound(Zeilen) & " Zeilen 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

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

  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 - 1
            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!
'******************************

Beliebteste Forumthreads (12 Monate)

Schwierige Übernahme einer txt Datei in Excel

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

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread