Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - 35. Unikatowe,losowo uporządkowane liczby

master_mix · Excel Expert Posty: 1615

Jako że ostatnimi czasy było kilka tematów na temat liczb losowych,
zamieszczam funkcję która w sposób losowy wstawia niepowtarzające się
liczby w dowolnym
zaznaczonym zakresie

Kod:

Function RANDOMINTEGERS()
Dim FuncRange As Range
Dim V() As Variant, ValArray() As Variant
Dim CellCount As Double
Dim i As Integer, j As Integer
Dim r As Integer, c As Integer
Dim Temp1 As Variant, Temp2 As Variant
Dim RCount As Integer, CCount As Integer

Randomize

Set FuncRange = Application.Caller

CellCount = FuncRange.Count
If CellCount > 1000 Then
RANDOMINTEGERS = CVErr(xlErrNA)
Exit Function
End If

RCount = FuncRange.Rows.Count
CCount = FuncRange.Columns.Count
ReDim V(1 To RCount, 1 To CCount)
ReDim ValArray(1 To 2, 1 To CellCount)

For i = 1 To CellCount
ValArray(1, i) = Rnd
ValArray(2, i) = i
Next i

For i = 1 To CellCount
For j = i + 1 To CellCount
If ValArray(1, i) > ValArray(1, j) Then
Temp1 = ValArray(1, j)
Temp2 = ValArray(2, j)
ValArray(1, j) = ValArray(1, i)
ValArray(2, j) = ValArray(2, i)
ValArray(1, i) = Temp1
ValArray(2, i) = Temp2
End If
Next j
Next i

i = 0
For r = 1 To RCount
For c = 1 To CCount
i = i + 1
V(r, c) = ValArray(2, i)
Next c
Next r
RANDOMINTEGERS = V
End Function

Zaznacz dowolny zakres komórek, wpisz =RANDOMINTEGERS() wciśnij Ctrl+Shift+Enter
... i gotowe

Losowe unikaty.rar

Pobierz Plik ściągnięto 153 raz(y) 9.6 KB

Trebor · Excel Expert Posty: 2319

To ja zaproponuje mój wynalazek o podobnym działaniu:

Kod:

Function losowo()
Dim tablica, tablica1(), zakres As Range
Dim i As Long, j As Long, ile As Long, los As Long, wiersz As Long
Dim kolumna As Integer, kolumn As Integer
Set zakres = Application.Caller
j = zakres.Count
ReDim tablica(1 To j, 1 To zakres.Columns.Count)
ReDim tablica1(1 To j)
'Wypełnienie tablicy

For i = 1 To j
tablica1(i) = i
Next i
Randomize
kolumn = zakres.Columns.Count
wiersz = 1
For ile = 1 To j
los = Int(((j + 1 - ile) * Rnd) + 1)
kolumna = kolumna + 1
If kolumna > kolumn Then kolumna = 1: wiersz = wiersz + 1
tablica(wiersz, kolumna) = tablica1(los)

'przepisanie tablicy
For i = los To j - ile
tablica1(i) = tablica1(i + 1)
Next i

Next ile
losowo = tablica
End Function

Pozdrawiam