Hej där

Har ett litet intrikat problem som jag skulle behöva hjälp med då jag inte är tillräckligt bra på det här med macron...
Har fått på mig att titta på ett excelprogram för hundtävlingar där det bl.a. ska slumpas startordning. I omgång ett är det bara en enkel slumsortering som gäller och den fungerar som den ska. I omgång två ska hundarna dels paras ihop så att ettan och tvåan springer ihop, trean och fyran springer ihop osv. samt att det ska slumpas vilket lopp de springer i och så långt fungerar allt som det ska. Det som skulle behövas ändras är att den hunden med högre poäng inte alltid hamnar på plats ett i varje lopp och den med lägre poäng hamnar på plats två. De skall alltså läggas in i samma lopp men så att den med den högre poängen omväxlande hamnar på plats ett eller två i de olika loppen.

 Koden ser ut som följer:
Sub Slumpsortering()

Dim rnum
Dim arr()
Dim i As Long
Dim x As Long
Dim col As Long
Dim nrow As Long
Dim srow As Long
Dim countt As Long
Dim nyrad As Long
Dim nykol As Long

'turn off screen for speed
'Application.ScreenUpdating = False

'get start row number
srow = 7

'get current col #
If slump.Omg.Value = "Omg 1" Then
    col = 9
Else
    col = 12
End If

nrow = srow

'get number of rows
countt = 0
Do While Cells(nrow, col) > 0
    countt = countt + 1
    nrow = nrow + 1
    'MsgBox "Countt: " & countt & " Nrow: " & nrow, vbInformation
Loop

col = 9

'set array length
If slump.Omg.Value = "Omg 1" Then
    ReDim arr(countt)
Else
    ReDim arr(countt + 1)
End If

'arr index
x = 1

'load array with values
For i = 1 To countt
If Cells(srow, 17) = 0 Then
    'MsgBox Cells(srow, 17), vbInformation
    arr(x) = Cells(srow, col)
    'MsgBox "2 Srow " & srow & "-x-" & x & " i " & i, vbInformation
    x = x + 1
Else
    countt = countt - 1
'    MsgBox Cells(srow, 17), vbInformation
End If
srow = srow + 1
Next i

'MsgBox "Vidare", vbInformation

'reset i
i = 1

nyrad = 7
If slump.Omg.Value = "Omg 1" Then
    nykol = 2
    'repopulate selection 'randomly'
    Do Until i = countt + 1
    Randomize
        rnum = Int((countt - 1 + 1) * Rnd + 1)
        If arr(rnum) <> "" Then
            Cells(nyrad, nykol) = arr(rnum)
            arr(rnum) = ""
            i = i + 1
            nyrad = nyrad + 1
        End If
    Loop
Else
    nykol = 6
    arr(x) = ""
    Do Until i >= countt + 1
        rnum = Int((countt - 1 + 1) * Rnd + 1)
        'MsgBox rnum & "::" & i & "::" & countt + 1 & countt
        If arr(rnum) <> "" Then
            If rnum Mod 2 <> 0 Then
                Cells(nyrad, nykol) = arr(rnum)
                Cells(nyrad + 1, nykol) = arr(rnum + 1)
                arr(rnum) = ""
                arr(rnum + 1) = ""
                i = i + 2
                nyrad = nyrad + 2
            End If
        End If
    Loop
End If

'turn on screen
'Application.ScreenUpdating = True
End Sub
Sub Visa_slump()
    slump.Show
End Sub