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