Hier noch ein wenig kommentiert.
(Das ginge auch etwas einfacher, aber der Code soll die
einzelnen Schritte und Teilaufgaben deutlich machen ....)
Option Explicit
Private Sub Form_Load()
'Der Aufruf der Routine
FillOutput
End Sub
Private Function CountLines(ByVal file As String) As Integer
'Diese Funktion zählt die Zahl der Zeilen in der Datei
Dim k As Integer, z As Integer, line As String
k = FreeFile
Open file For Input As #k
While Not EOF(k)
Line Input #k, line
z = z + 1
Wend
Close #k
CountLines = z
End Function
Private Function GetLines(ByVal file As String) As String()
'Diese Funktion lädt die Zeilen in einer Datei in ein StringArray
Dim l As Integer
l = CountLines(file) 'Zahl der Zeilen bestimmen
Dim lines() As String
ReDim lines(l) As String
Dim k As Integer, z As Integer
k = FreeFile
Open file For Input As #k
z = 1
While Not EOF(k)
Line Input #k, lines(z)
z = z + 1
Wend
Close #k
GetLines = lines
End Function
Private Function GetLine(line As String) As Integer()
'Dies Funktion zerlegt eine Dateizeile (String) anhand des
'Feldtrennzeichens , in ein Array von Integern
Dim parts() As String
parts = Split(line, ",")
Dim ints() As Integer
ReDim ints(UBound(parts)) As Integer
Dim i As Integer
For i = 0 To UBound(parts)
ints(i) = CInt(parts(i))
Next i
GetLine = ints
End Function
Private Function CompareLines(line1() As Integer, _
line2() As Integer) As Boolean
'Diese Funktion zählt, wieviele Integerwerte in beiden
'Arrays (line1, line2) vorkommen und gibt true zurück,
'wenn mehr als vier Werte identisch sind
Dim i As Integer, k As Integer, id As Integer
For i = 0 To UBound(line1)
For k = 0 To UBound(line2)
If line1(i) = line2(k) Then id = id + 1
Next k
Next i
CompareLines = id > 4
End Function
Private Function CompareLines2(line1() As Integer, _
line2() As Integer) As String
'Diese Funktion zählt, wieviele Integerwerte in beiden
'Arrays (line1, line2) vorkommen (CompareLines) und gibt
'den Wertstring zurück, wenn mehr als vier Werte identisch sind
CompareLines2 = ""
Dim i As Integer, k As Integer, id As Integer
Dim lineout As String
If CompareLines(line1, line2) Then
'.... es sind mehr als vier gleiche Werte vorhanden
For i = 0 To UBound(line1)
For k = 0 To UBound(line2)
If line1(i) = line2(k) Then _
lineout = lineout & CStr(line1(i)) & ", "
Next k
Next i
If Len(lineout) > 2 Then
lineout = Left(lineout, Len(lineout) - 2)
End If
CompareLines2 = lineout
End If
End Function
Private Sub FillOutput()
'Diese Funktion liest die Zeilen einer Datei (6 Integer pro Zeile, getrennt
' durch ,)
'und gibt für alle paarweisen Zeilenvergleiche, bei denen mehr als
'vier Werte identisch sind, diejenigen Werte aus, die in beiden Zeilen
' vorkommen
Dim file As String
file = "C:\daten\input.txt"
'Alle Zeilen lesen
Dim lines() As String
lines = GetLines(file)
'Ausgabe öffnen
Dim ak As Integer
ak = FreeFile
Open "C:\daten\output.txt" For Output As #ak
Dim i As Integer, k As Integer
Dim line1() As Integer, line2() As Integer
Dim lineout As String
'Schleife über alle Zeilen(strings)
For i = 1 To UBound(lines)
'Werte in Zeile besorgen
line1 = GetLine(lines(i))
'Schleife über alle Folgezeilen
For k = i + 1 To UBound(lines)
line2 = GetLine(lines(k))
'Zeile i, k vergleichen
lineout = CompareLines2(line1, line2)
If Not lineout = "" Then
'Falls mehr als vier identische Werte ...
Write #ak, lineout
End If
Next k
Next i
Close #ak
End Sub
Beitrag wurde zuletzt am 06.03.14 um 20:58:22 editiert. |