VBA tilfældige tal

Function SortArray(varArray)
    For i = UBound(varArray) - 1 To 1 Step -1
        MaxVal = varArray(i)
        MaxIndex = i
   
        For j = 0 To i
            If varArray(j) > MaxVal Then
                MaxVal = varArray(j)
                MaxIndex = j
            End If
        Next
   
        If MaxIndex < i Then
            varArray(MaxIndex) = varArray(i)
            varArray(i) = MaxVal
        End If
    Next
End Function

Sub randNums()
diffLow = 5
diffHeigh = 12
intLow = 1
intHeigh = 29
repeats = 2

Randomize

Dim a(3)

For i = 1 To repeats
Do
a(0) = Int(Rnd * intHeigh) + intLow
a(1) = Int(Rnd * intHeigh) + intLow
a(2) = Int(Rnd * intHeigh) + intLow
SortArray (a)
If a(1) - a(0) > diffLow And a(1) - a(0) < diffHeigh Then
If a(2) - a(1) > diffLow And (2) - a(1) < diffHeigh Then
    Cells(1, i) = a(0)
    Cells(2, i) = a(1)
    Cells(3, i) = a(2)
    Exit Do
End If
End If
Loop
Next

End Sub

Ups...der var en fejl...

Function SortArray(varArray)
    For i = UBound(varArray) - 1 To 1 Step -1
        MaxVal = varArray(i)
        MaxIndex = i
   
        For j = 0 To i
            If varArray(j) > MaxVal Then
                MaxVal = varArray(j)
                MaxIndex = j
            End If
        Next
   
        If MaxIndex < i Then
            varArray(MaxIndex) = varArray(i)
            varArray(i) = MaxVal
        End If
    Next
End Function

Sub randNums()
diffLow = 5
diffHeigh = 12
intLow = 1
intHeigh = 29
repeats = 60

Randomize

Dim a(3)

For i = 1 To repeats
Do
a(0) = Int(Rnd * (intHeigh - intLow + 1)) + intLow
a(1) = Int(Rnd * (intHeigh - intLow + 1)) + intLow
a(2) = Int(Rnd * (intHeigh - intLow + 1)) + intLow
SortArray (a)
If a(1) - a(0) > diffLow And a(1) - a(0) < diffHeigh Then
If a(2) - a(1) > diffLow And (2) - a(1) < diffHeigh Then
    Cells(1, i) = a(0)
    Cells(2, i) = a(1)
    Cells(3, i) = a(2)
    Exit Do
End If
End If
Loop
Next

End Sub

Skal blot kopieres ind som makro randNums()

Endnu et bud - del 2 følger i givet fald:

Sub beregnTal()
Dim tal, maks, mini, midi, antalOK
    For kol = 1 To 60
        Randomize    ' Initialize random-number generator.
        antalOK = 0
        While antalOK < 3
            For ræk = 1 To 3
                tal = Int((29 * Rnd) + 1)    ' Generate random value between 1 and 6.
                Cells(ræk, kol) = tal
            Next ræk
       
            Cells(1, kol).Select
            sorter Selection.Address
            mini = Cells(1, kol)
            midi = Cells(2, kol)
            maks = Cells(3, kol)
           
            antalOK = antalOK + diff(maks, midi)
            antalOK = antalOK + diff(midi, mini)
            antalOK = antalOK + diff2(maks, midi, mini)
           
            If antalOK < 3 Then
                antalOK = 0
            End If
        Wend
    Next kol
End Sub
Private Sub sorter(adresse)
Dim p, adr
    adr = Mid(adresse, 2)
    p = InStr(adr, "$")
    kolonne = Left(adr, p - 1)
   
    Range(kolonne + "1:" + kolonne + "3").Select
    Selection.Sort Key1:=Range(kolonne + "1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End Sub
Private Function diff(tal1, tal2)
    If tal1 - tal2 >= 5 And tal1 - tal2 <= 12 Then
        diff = 1
    Else
        diff = 0
    End If
End Function
Private Function diff2(tal1, tal2, tal3)
    If tal1 - tal2 <> tal2 - tal3 Then
        diff2 = 1
    Else
        diff2 = 0
    End If
End Function

Version 2 med mulighed for ændring af beregnings-parametre:

Rem Beregningsparametre    'Default
Const antalRæk = 10        '60
Const MaxTal = 33          '29
Const MinTal = 8            '1
Const MaxDiff = 14          '12
Const MinDiff = 7          '5
Sub beregnTal()
Dim tal, maks, mini, midi, antalOK
    For kol = 1 To antalRæk
        Randomize
        antalOK = 0
        While antalOK < 3
            For ræk = 1 To 3
                tal = Int((MaxTal * Rnd) + MinTal)
                Cells(ræk, kol) = tal
            Next ræk
       
            Cells(1, kol).Select
            sorter Selection.Address
            mini = Cells(1, kol)
            midi = Cells(2, kol)
            maks = Cells(3, kol)
           
            antalOK = antalOK + diff(maks, midi)
            antalOK = antalOK + diff(midi, mini)
            antalOK = antalOK + diff2(maks, midi, mini)
           
            If antalOK < 3 Then
                antalOK = 0
            End If
        Wend
    Next kol
End Sub
Private Sub sorter(adresse)
Dim p, adr
    adr = Mid(adresse, 2)
    p = InStr(adr, "$")
    kolonne = Left(adr, p - 1)
   
    Range(kolonne + "1:" + kolonne + "3").Select
    Selection.Sort Key1:=Range(kolonne + "1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End Sub
Private Function diff(tal1, tal2)
    If tal1 - tal2 >= MinDiff And tal1 - tal2 <= MaxDiff Then
        diff = 1
    Else
        diff = 0
    End If
End Function
Private Function diff2(tal1, tal2, tal3)
    If tal1 - tal2 <> tal2 - tal3 Then
        diff2 = 1
    Else
        diff2 = 0
    End If
End Function

Tak for koderne!

Mikkelk, kan du lave det sådan, at de 3 tal står i tilfældig rækkefølge og ikke stigende?
Derudover ser det ud til, at min regel om:
"Derudover må forskellen mellem det midterste tal og det største ikke være det samme som forskellen mellem det midterste og det mindste."
ikke er opfyldt. Kan du løse den?

Supertekst, jeg får ikke din kode til virke.
Den står bare og sorterer i cellerne A1:A3.

Nå ja, det havde jeg da lige overset :-) Her kommer en rettet udgave:
Function SortArray(varArray)
    For i = UBound(varArray) - 1 To 1 Step -1
        MaxVal = varArray(i)
        MaxIndex = i
 
        For j = 0 To i
            If varArray(j) > MaxVal Then
                MaxVal = varArray(j)
                MaxIndex = j
            End If
        Next
 
        If MaxIndex < i Then
            varArray(MaxIndex) = varArray(i)
            varArray(i) = MaxVal
        End If
    Next
End Function

Sub randNums()
diffLow = 5
diffHeigh = 12
intLow = 1
intHeigh = 29
repeats = 60

Randomize

Dim a(3)

For i = 1 To repeats
Do
a(0) = Int(Rnd * (intHeigh - intLow + 1)) + intLow
a(1) = Int(Rnd * (intHeigh - intLow + 1)) + intLow
a(2) = Int(Rnd * (intHeigh - intLow + 1)) + intLow
SortArray (a)
lowDiff = a(1) - a(0)
heighDiff = a(2) - a(1)
If lowDiff > diffLow And lowDiff < diffHeigh And heighDiff > diffLow And heighDiff < diffHeigh And lowDiff <> heighDiff Then
    Cells(1, i) = a(0)
    Cells(2, i) = a(1)
    Cells(3, i) = a(2)
    Exit Do
End If
Loop
Next

End Sub

En sjov lille opgave :-)
Men må man spørge hvad det skal bruges til?

mikkelk, det ser fint ud, kunne du også lade de 3 tal komme i tilfældig rækkefølge?

Tallene skal bruges, som en del af en anerkendt intelligenstest.
Den går i al sin enkelthed ud på, at man skal finde det midterste tal og så regne ud, hvilket af de 2 øvrige, som ligger længst fra middeltallet.
Til de 60 opgaver har man så 4 minutter.

Ok...sjovt :-)
Her, rettet udgave(Erstatter tidligere helt, da jeg også fandt et par småfejl):
Function SortArray(varArray)
    For i = UBound(varArray) - 1 To 1 Step -1
        MaxVal = varArray(i)
        MaxIndex = i
 
        For j = 0 To i
            If varArray(j) > MaxVal Then
                MaxVal = varArray(j)
                MaxIndex = j
            End If
        Next
 
        If MaxIndex < i Then
            varArray(MaxIndex) = varArray(i)
            varArray(i) = MaxVal
        End If
    Next
    SortArray = varArray
End Function

Sub randNums()
diffLow = 5
diffHeigh = 12
intLow = 1
intHeigh = 29
repeats = 60

Randomize

For i = 1 To repeats
Do
ReDim a(3), b(3)
a(0) = Int(Rnd * (intHeigh - intLow + 1)) + intLow
a(1) = Int(Rnd * (intHeigh - intLow + 1)) + intLow
a(2) = Int(Rnd * (intHeigh - intLow + 1)) + intLow
b(0) = a(0)
b(1) = a(1)
b(2) = a(2)

a = SortArray(a)

lowDiff = a(1) - a(0)
heighDiff = a(2) - a(1)
If lowDiff > diffLow And lowDiff < diffHeigh And heighDiff > diffLow And heighDiff < diffHeigh And lowDiff <> heighDiff Then
    Cells(1, i) = b(0)
    Cells(2, i) = b(1)
    Cells(3, i) = b(2)
    Exit Do
End If
Loop
Next

End Sub

Mange tak for hjælpen. Det fungerer perfekt.

Jeg har udvidet modellen lidt, så den er klar til test, og også indeholder kontrolfunktion. Det går lige med at klare 60 rigtige på 4 min., men man må ikke have mange "koncentrationssvigt" :-)

Det ser ud til, at der stadig er en fejl.
Hvis diffLow sættes til 8 og diffHeigh sættes til 12
får jeg kun udfalds-differencerne 9,10 og 11. 8 og 12 burde vel også være inkluderet.

Takker for point :-)
Rettet udgave, så diffLow og diffHeigh indgår i intervallet:

Function SortArray(varArray)
    For i = UBound(varArray) - 1 To 1 Step -1
        MaxVal = varArray(i)
        MaxIndex = i
 
        For j = 0 To i
            If varArray(j) > MaxVal Then
                MaxVal = varArray(j)
                MaxIndex = j
            End If
        Next
 
        If MaxIndex < i Then
            varArray(MaxIndex) = varArray(i)
            varArray(i) = MaxVal
        End If
    Next
    SortArray = varArray
End Function

Sub randNums()
diffLow = 5
diffHeigh = 12
intLow = 1
intHeigh = 29
repeats = 60

Randomize

For i = 1 To repeats
Do
ReDim a(3), b(3)
a(0) = Int(Rnd * (intHeigh - intLow + 1)) + intLow
a(1) = Int(Rnd * (intHeigh - intLow + 1)) + intLow
a(2) = Int(Rnd * (intHeigh - intLow + 1)) + intLow
b(0) = a(0)
b(1) = a(1)
b(2) = a(2)

a = SortArray(a)

lowDiff = a(1) - a(0)
heighDiff = a(2) - a(1)
If lowDiff >= diffLow And lowDiff <= diffHeigh And heighDiff >= diffLow And heighDiff <= diffHeigh And lowDiff <> heighDiff Then
    Cells(1, i) = b(0)
    Cells(2, i) = b(1)
    Cells(3, i) = b(2)
    Exit Do
End If
Loop
Next

End Sub

Beklager, men så går det helt galt med .....
Det ser ud til, at intervallerne nu går fra 0 til 20 eller sådan noget lignende ...

Det gør det ikke når jeg kører den...det er vel differencerne mellem højste/midterste og laveste/midterste der skal ligge i intervallet - og det gør de altså...

Ved ikke hvad der skete - det virker ihvertfald nu .... beklager!

:-) Det er helt iorden. God fornøjelse med det.