Option Explicit
 
Private Type Wechsel2
    vorher As Integer
    freqvorher As Integer
    nachher As Integer
    anzahl As Integer
End Type
 
Private register() As Wechsel2
 
Private Sub RegistriereWechsel(ByVal vorher As Integer, _
                               ByVal freqvorher As Integer, _
                               ByVal nachher As Integer)
 
   Dim i As Integer, gefunden As Boolean
 
   gefunden = False
   For i = 1 To UBound(register)
      With register(i)
         If .vorher = vorher And .nachher = nachher _
            And .freqvorher = freqvorher Then
             'vorhandener Wechsel / Zählen
             .anzahl = .anzahl + 1
             gefunden = True: Exit For
         End If
      End With
   Next i
 
   If Not gefunden Then
       'neuer Wechsel
       i = UBound(register) + 1
       ReDim Preserve register(i)
       Dim w As Wechsel2
       w.vorher = vorher
       w.freqvorher = freqvorher
       w.nachher = nachher
       w.anzahl = 1
       register(i) = w
  End If
 
 
End Sub
 
Private Function NumLen(ByVal number As Integer, _
                       minlen As Integer) As String
 
    'Formatierung der Ausgabe
 
    NumLen = CStr(number)
    While Len(NumLen) < minlen
        NumLen = " " & NumLen
    Wend
 
End Function
 
 
Private Sub Form_Load()
    ReDim register(0)
 
    Dim ik%, ak%, i%, z%, w%
    Dim fv% 'Frequenz der Folge vor dem Wechsel zählen
    Dim number1%, number2%
 
    ik = FreeFile
    Open "C:\daten\suchen-neu.txt" For Input As #ik
 
    'Datei lesen
    Input #ik, number1
 
    While Not EOF(ik)
        Input #ik, number2
        fv = fv + 1
        If Not number1 = number2 Then
           RegistriereWechsel number1, fv, number2
           w = w + 1
           fv = 0
        End If
        number1 = number2
        z = z + 1
    Wend
    Close #ik
 
    ak = FreeFile
 
    QuickSort register, 1, UBound(register)
 
    'Ausgabe füllen
    Open "C:\daten\zahlenübergänge2.txt" For Output As #ak
 
    Print #ak, "Anzahl Zahlen: "; z
    Print #ak, "Anzahl Übergänge: "; w
    Print #ak, ""
 
    For i = 1 To UBound(register)
        With register(i)
            Print #ak, "Nach "; NumLen(.vorher, 3); " folgt "; _
            NumLen(.nachher, 3); " = "; NumLen(.anzahl, 3); "x, wenn "; _
            NumLen(.vorher, 3) & " = " & NumLen(.freqvorher, 3) & "x bestanden" & _
            "hat"
        End With
    Next i
 
    Close #ak
 
End Sub
 
 
Private Sub QuickSort(Sort() As Wechsel2, ByVal Start%, ByVal Ende%)
 
  Dim i%, j%
  Dim h As Wechsel2
  Dim x As Wechsel2
 
  i = Start: j = Ende
  x = Sort((Start + Ende) / 2)
 
  ' Array aufteilen
  Do
 
    While comparewechsel(Sort(i), x) < 0: i = i + 1: Wend
    While comparewechsel(Sort(j), x) > 0: j = j - 1: Wend
 
    If (i <= j) Then
      ' Wertepaare miteinander tauschen
      h = Sort(i)
      Sort(i) = Sort(j)
      Sort(j) = h
      i = i + 1: j = j - 1
    End If
  Loop Until (i > j)
 
  If (Start < j) Then QuickSort Sort, Start, j
  If (i < Ende) Then QuickSort Sort, i, Ende
End Sub
 
Private Function comparewechsel(w1 As Wechsel2, w2 As Wechsel2) As Integer
    comparewechsel = 1
    If w1.vorher > w2.vorher Then Exit Function
    If w1.vorher = w2.vorher And _
       w1.nachher > w2.nachher Then Exit Function
    comparewechsel = 0
    If w1.vorher = w2.vorher And _
       w1.nachher = w2.nachher Then Exit Function
    comparewechsel = -1
End Function