AW: Josef - Textfile einlesen - Nachtrag!
17.02.2005 10:43:46
Josef
Hallo Karl-Heinz!
Da der Aufbau des Textfiles komplett unterschiedlich ist, muss man
die Aufbereitung des String neu gestalten!
Sub sucheInTextFile2()
Dim x As Long, lRow As Long
Dim Zeilen() As String, FName As String, sText As String
Dim tmp As String, s1 As String, s2 As String, s3 As String
Dim n1 As Integer, n2 As Integer, n3 As Integer, n4 As Integer, iCnt As Integer
Dim arrS As Variant
'On Error GoTo ERRORHANDLER
'Datei auswählen
FName = Application.GetOpenFilename("Textl Dateien (*.txt)," & _
"*.txt")
If FName = "Falsch" Then Exit Sub
'Suchbegriff(e) eingeben
sText = InputBox("Bitte gesuchte Nummer Eingeben!" & vbLf & vbLf & _
"Mehrere Nummern durch "","" trennen!", _
"Suche", "0171") 'Suchtext
If sText = "" Then Exit Sub
'Suchbegriff von falscheingaben (",", ":", ".", " ") bereinigen
sText = Trim(Replace(Replace(Replace(Replace(sText, ";", ","), ".", ","), ":", ","), " ", ""))
'Suchbegriffe aufteilen
arrS = Split(sText, ",")
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
'.Cursor = xlWait
End With
Range("A:C").ClearContents 'Datenbereich löschen
'Schleife über die Suchbegriffe
For iCnt = 0 To UBound(arrS)
'Die letzten beiden Parameter geben das linke und rechte
'Begrenzungszeichen einer Zeile an, dies können auch
'mehrere sein.
If FindTerm(FName, CStr(arrS(iCnt)), Zeilen, vbLf, vbLf) Then
'Scleife um die Fundstellen
For x = 0 To UBound(Zeilen) - 1
tmp = Trim(Zeilen(x))
Do While InStr(1, tmp, " ") > 0
tmp = Trim(Replace(tmp, " ", " "))
Loop
n1 = InStr(1, tmp, " ") 'erste Leerstelle suchen
n2 = InStr(n1 + 1, tmp, " ") 'zweite Leerstelle suchen
n3 = InStr(n2 + 1, tmp, " ") 'dritte Leerstelle suchen
n4 = InStr(1, tmp, CStr(Year(Date))) - 1 'Jahreszahl suchen
s1 = Trim(Mid(tmp, n1, n2 - n1)) 'Anrufende Nummer
s2 = Trim(Mid(tmp, n2, n3 - n2)) 'Angerufene Nummer
s3 = Mid(tmp, n4 + 1, 8) 'Datum
'Daten nur eintragen, wenn gesuchte Nummer in der
'angerufenen Nummer vorhanden
If InStr(1, s2, CStr(arrS(iCnt))) = 1 Then
lRow = lRow + 1
Cells(lRow, 1) = s1
Cells(lRow, 2) = s2
Cells(lRow, 3) = DateValue(Left(s3, 4) & "." & _
Mid(s3, 5, 2) & "." & Right(s3, 2))
End If
'End If
Next
End If
Next
If lRow > 0 Then
MsgBox "Es wurden " & lRow & " 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
Die Funktion "FindTerm" bleibt unverändert!