Tilfældige tal og lodtrækning med Excel VBA

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

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