RSS

Tilfældige tal og lodtrækning med Excel VBA

En læser spurgte, om jeg ville lave et eksempel på, hvordan man genererer tilfældige tal med Excel VBA, og det vil jeg da, for opgaven er sjov.

Tilfældige tal kan fx bruges til stikprøvekontrol, kryptering eller lodtrækning, og det er en matematisk videnskab for sig.

Med regnearksfunktionen "= SLUMP()" kan man få et tilfældigt tal i en celle, og i VBA bruger man funktionen "Rnd()".

For at vende tilbage til læserens ønske, skulle der fra en tabel udtrækkes syv tilfældige og forskellige "vindertal". Det indebærer, at hvis det samme tal optræder flere gange i tabellen, ja så vil det have større sandsynlighed for at blive udtrukket - altså en form for snyd.

Herunder bringer jeg et eksempel på, hvordan det kan gøres (proceduren Lottosnyd). Bagefter viser jeg, hvordan VBA kan lave en tabel med unikke tilfældige tal (altså uden dubletter), så man kan få en fair lodtrækning.

Eksemplet viser også, hvordan man kan definere et interval for det tilfældige tal (fx 1 - 1000).

Om pseudotilfældige tal

Før jeg går videre, må jeg dog skynde mig at sige, at Excel ikke laver ægte tilfældige tal som fx kast med en terning, men såkaldt psudotilfældige tal.

VBA (og andre programmer) bruger en algoritme, som tager udgangspunkt i en "seed value". Ofte bruges computerens ur til at generere denne startværdi.

Kender man værdien, kan man regne de "tilfældige" tal ud (hvis man er skrap!), og det vil jo være ret uheldigt, hvis de fx bruges til kryptering eller lotto!

Kommandoen "Randomize" bruges i VBA til at resette talgeneratoren, så den får en ny seed value.

Det er altsammen lidt langhåret, og jeg henviser til fx Wikipedia, hvor du kan læse mere om pseudotilfældige tal.

Lodtrækning

Herunder følger et eksempel på lodtrækning fra en tabel. Eksemplet forudsætter, at der er en tabel startende i celle A1 på det første faneblad. Du kan kopiere koden ved at markere den med musen og kopiere med CTRL+C og så sætte den ind med CTRL+V i et VBA-modul i Excel.


Sub Lottosnyd()
'Trækker lod mellem værdierne i en tabel
'og finder 7 forskellige vindertal.
'Hvis tabellen indeholder flere
'forekomster af et bestemt tal, vil sand-
'synligheden stige, for at netop dette tal
'udtrækkes.

Dim lVal As Long
Dim rInput As Range
Dim rCell As Range
Dim colTjek As Collection
Dim colVindere As Collection

On Error GoTo ErrorHandle

'Det antages, at tabellen står på det første
'faneblad, og at celle A1 indgår. Vores range,
'rInput, sættes = tabellen.
Set rInput = Worksheets(1).Range("A1").CurrentRegion

'Tjekker at der er mindst 8 celler
'i tabellen.
If rInput.Count < 8 Then
   MsgBox "Der er for få celler i tabellen.", vbCritical
   GoTo BeforeExit
End If

'Tjekker at cellerne kun indeholder tal og
'ikke er tomme.
For Each rCell In rInput
   If IsNumeric(rCell.Value) = False Or Len(rCell.Value) = 0 Then
      MsgBox "Cellerne skal indeholde tal.", vbCritical
      GoTo BeforeExit
   End If
Next

On Error Resume Next

'Tjekker at der er mindst 8 forskellige værdier.
'Dette gøres ved at tilføje tallene til en collection
'som "Key" (nøgle). Collections accepterer kun unikke
'nøgler, og "On Error Resume Next" ovenover sikrer
'at programmet ikke crasher med en fejl, hvis der
'forsøges tilføjet en dublet.
Set colTjek = New Collection
For Each rCell In rInput
   With rCell
      'Tallet konverteres til heltal og en String,
      'før det bruges som Key.
      colTjek.Add Int(.Value), Str$(Int(.Value))
   End With
   'Løkken stoppes, i det øjeblik der er
   '8 forskellige værdier i colTjek.
   If colTjek.Count = 8 Then Exit For
Next

'Vi afbryder, hvis der ikke er mindst 8 forskellige
'tal i tabellen.
If colTjek.Count < 8 Then
   MsgBox "Der skal være mindst 8 forskellige tal i tabellen."
   GoTo BeforeExit
End If

Set colVindere = New Collection

'Resetter talgeneratoren så den får en ny
'"seed value" fra computerens klokke.
'Om seed values se:
'http://en.wikipedia.org/wiki/Random_seed
Randomize

'Nu findes 7 tilfældige tal mellem 1 og antallet
'af celler i tabellen. Værdien i cellen, som har
'det tilsvarende "medlemsnummer" i rInput, tilføjes
'samlingen colVindere. Ved samtidig at tilføje værdien
'som Key (String) sikres, at der ikke kommer dubletter
' - altså kun én forekomst af hvert vindertal.
For Each rCell In rInput
   With rInput
      'Et tilfældigt heltal genereres. Tallet
      'vil være mellem 1 og antallet af celler
      'i tabellen.
      lVal = Int(.Count * Rnd() + 1)

      'Værdien i cellen, som har det tilfældige
      'nummer i ranget rInput, tilføjes
      'colVindere. Hvis værdien allerede findes,
      'tilføjes den ikke.
      colVindere.Add Int(.Item(lVal).Value), _
      Str$(Int(.Item(lVal).Value))
      If colVindere.Count = 7 Then Exit For
   End With
Next

On Error GoTo ErrorHandle

'De udtrukne vindertal indsættes på
'faneblad 2.
Set rCell = Worksheets(2).Range("A1")
rCell.Value = "Udtrukne vindertal:"
With colVindere
   For lVal = 1 To .Count
      rCell.Offset(lVal, 0).Value = .Item(lVal)
   Next
End With

'Aktiverer fanebladet med vindernumrene.
Worksheets(2).Activate

BeforeExit:
Set rCell = Nothing
Set rInput = Nothing
Set colTjek = Nothing
Set colVindere = Nothing

Exit Sub
ErrorHandle:
MsgBox Err.Description & " Fejl i procedure Lottosnyd."
Resume BeforeExit
End Sub

Tabel med unikke tilfældige tal

Nedenstående eksempel viser, hvordan man kan lave en tabel med unikke tilfældige tal - altså uden dubletter.

Hvis man bruger denne procedure, kan man lave en fair lodtrækning med proceduren ovenover (og så bør man nok ikke kalde den "Lottosnyd"!).

Igen: Du kan markere koden med musen, kopiere med CTRL+C og indsætte den i et VBA-modul med CTRL+V.


Sub LavUnikTabel()
'Laver en tabel med tilfældige heltal
'uden dubletter. Tricket til at undgå dubletter
'er at tilføje værdierne til en collection og
'samtidig lade værdien være "nøgle".
'Nøglerne i en collection skal nemlig være
'unikke, og hvis man forsøger at tilføje en
'allerede eksisterende nøgle, udløser det en
'fejl, og det er dette, vi udnytter.

'OBS! Ved meget store tabeller er dette en
'tidskrævende metode, idet der med stor
'sandsynlighed genereres tal, som allerede
'findes i tabellen, og så tager det ekstra
'tid at blive færdig. Normalt er hastigheden
'dog så høj, at det er ligegyldigt, og man kan
'reducere sandsynligheden for dubletter ved at
'øge intervallet for de tilfældige tal.

Dim rTabel As Range
Dim rCell As Range
Dim lMin As Long
Dim lMax As Long
Dim lVal As Long
Dim colValues As Collection

On Error GoTo ErrorHandle

'Tabelområdet defineres som området A1 til J30
'på det første faneblad.
Set rTabel = Worksheets(1).Range("A1", "J30")

'Definerer intervallet (her 1 til 1000).
lMin = 1
lMax = 1000

'Kontrol: Intervallet skal være mindst lige så
'stort som antallet af celler i tabellen.
If lMax - lMin < rTabel.Count Then
   MsgBox "Intervallet er for lille.", vbCritical
   GoTo BeforeExit
End If

'Resetter talgeneratoren så den får en ny seed value.
Randomize

Set colValues = New Collection

'Fidusen til kun at få unikke værdier ligger i at
'vi nu sætter fejlbehandlingen til "Resume Next".
'Uden On Error Resume Next ville programmet gå ned,
'hvis man prøvede at tildele en allerede eksisterende
'nøgle. Nu derimod fortsætter programmet bare.

On Error Resume Next

'Nu starter vi løkken som genererer tilfældige tal.
'Løkken kører, indtil colValues indeholder lige så
'mange tal, som der er celler i tabellen, rTabel.
Do Until colValues.Count = rTabel.Count
   'lVal sættes lig et tilfældigt heltal i
   'vores definerede interval.
   lVal = Int((lMax - lMin + 1) * Rnd() + lMin)

   'Føj til colValues med tallet som nøgle
   colValues.Add lVal, Str$(lVal)
Loop

On Error GoTo ErrorHandle

'colValues gennemløbes, og værdierne sættes
'ind i tabellen.
With colValues
   For lVal = 1 To .Count
      rTabel.Item(lVal).Value = .Item(lVal)
   Next
End With

BeforeExit:
Set rCell = Nothing
Set rTabel = Nothing
Set colValues = Nothing

Exit Sub
ErrorHandle:
MsgBox Err.Description & " Fejl i proceduren LavUnikTabel."
Resume BeforeExit
End Sub

Afslutningsvis vil jeg gøre opmærksom på, at funktionen Rnd() gerne returnerer tal med decimaler, og at jeg i mine eksempler har konverteret tallene til heltal med VBA-funktionen Int().

Relateret: