Need custom sorting algorithm

[bplus]

Finally got it, took forever to get the results printed out in columns on the default screen.
I did that matches as I explained in previous reply, comparing each column to every other one and counting up the matches.

Here is a screen shot of matching one column with another yellow is a match, blue is a miss:
   

Here is code:

Code: (Select All)

Const columns = 65, rows = 21 ' this is based on OP's screen shot
DefLng A-Z
' create some data randomly for testing
Dim cols$(1 To columns) ' make cols$()
For c = 1 To columns
    For r = 1 To rows
        cols$(c) = cols$(c) + IfS$(Int(Rnd * 2), "*", "-")
    Next
Next

'display
Color 7
For m = 1 To rows
    For c = 1 To columns
        Locate m, c: Print Mid$(cols$(c), m, 1);
    Next
Next
'        count matches and watch a color show!
' matches
Dim matches(1 To columns)
For i = 1 To columns - 1
    For j = i + 1 To columns
        match = 0
        For r = 1 To rows
            If Asc(cols$(i), r) = Asc(cols$(j), r) Then
                matches(i) = matches(i) + 1: matches(j) = matches(j) + 1
                Color 14
                Locate r, i: Print Mid$(cols$(i), r, 1);
                Locate r, j: Print Mid$(cols$(j), r, 1);
            Else
                Color 9
                Locate r, i: Print Mid$(cols$(i), r, 1);
                Locate r, j: Print Mid$(cols$(j), r, 1);
            End If
        Next
        _Delay .1
        Color 7
        For m = 1 To rows
            For c = 1 To columns
                Locate m, c: Print Mid$(cols$(c), m, 1);
            Next
        Next
    Next
Next

Color 15
Cls
Dim Shared IDX(1 To columns) ' swap ID when swap values
For i = 1 To columns
    IDX(i) = i
Next
QuickSort 1, columns, matches()
Open "Matches column ID.txt" For Output As #1
For i = 1 To columns
    If i < 21 Then
        c = 0
    ElseIf i < 41 Then
        c = 1
    ElseIf i < 61 Then
        c = 2
    Else
        c = 3
    End If
    If i Mod 20 = 0 Then c = c + 1
    Locate (i Mod 20) + 1, c * 20 + 1
    Print matches(i); IDX(i);
    Print #1, matches(i); IDX(i)
Next
Close #1
Locate 22, 1: Print


Sub QuickSort (start As Long, finish As Long, array() As Long)
    Dim Hi As Long, Lo As Long, Middle As Single
    Hi = finish: Lo = start
    Middle = array((Lo + Hi) / 2) 'find middle of array
    Do
        Do While array(Lo) < Middle: Lo = Lo + 1: Loop
        Do While array(Hi) > Middle: Hi = Hi - 1: Loop
        If Lo <= Hi Then
            Swap array(Lo), array(Hi)
            Swap IDX(Lo), IDX(Hi) ' track the IDX of the matches
            Lo = Lo + 1: Hi = Hi - 1
        End If
    Loop Until Lo > Hi
    If Hi > start Then Call QuickSort(start, Hi, array())
    If Lo < finish Then Call QuickSort(Lo, finish, array())
End Sub

Function IfS$ (Bool&, tru$, fals$) ' IF Boolean Return True$ else False$
    If Bool& Then IfS$ = tru$ Else IfS$ = fals$
End Function

Here is the results with increasing matches going down and to the right. The big number on left the match count the number on right the column number:
   

I even printed the results into a txt file just to make sure they were ordered correctly while I fiddled around trying to get the results listed right on the default screen:

Code: (Select All)

629  37
633  14
635  63
640  33
652  35
654  40
655  49
655  45
656  3
656  54
656  57
660  17
661  11
662  65
662  18
662  58
663  44
663  34
665  9
666  26
666  4
668  43
670  25
670  13
671  19
672  46
673  32
674  22
674  24
675  21
675  31
676  10
676  55
676  2
677  5
677  48
678  12
678  15
679  6
680  62
680  60
681  36
682  28
683  39
684  23
684  29
684  64
685  47
686  1
686  41
686  7
686  59
688  27
688  50
689  61
689  30
689  51
691  53
696  42
697  56
698  52
698  38
708  20
714  16
714  8