16. december 2003 - 10:59Der er
37 kommentarer og 1 løsning
VBA: Generering af bankoplader
Som fortsættelse på det udmærkede eksempel i http://www.eksperten.dk/spm/440099 kunne det være sjovt at udbygge eksemplet til også at kunne generere tilfældige bankoplader.
Der er mange milliarder kombinationsmuligheder, så man kommer ikke sådan lige til at generere to ens.
Reglerne for en bankoplade er følgende:
1) Der benyttes tal fra og med 1 til og med 90.
2) En spilleplade er regtangulær med 3 (vandrette) rækker og 9 (lodrette) kolonner, og hver spilleplade rummer 15 forskellige numre. Hver spilleplade har derfor udover numrene 12 blanke felter. 2 plader kan i princippet godt indeholde de samme 15 tal, men alligevel være forskellige fordi placeringen af de blanke felter er forskellig.
3) Numrene er sådan fordelt på pladen, at der er mindst 1 tal og højst 3 tal i hver kolonne og netop 5 tal i hver række.
4) I hver kolonne placeres tallene i stigende orden.
5) Kolonne 1 indeholder tallene 1-9, kolonne 2 indeholder tallene 10-19 osv. Dog indeholder kolonne 9 tallene 80-90.
Lad os tage bare sige, at arket skal laves i området A1:I3.
Er der nogen, som kan lave VBA-koden til ovenstående?
Her er et bud, men mangler sortering, så mindste tal står først.
Public Sub BingoPlader() Dim C(3) As Variant, UU(3) As Integer, X As Variant, U As Integer, I As Integer, Lille As Variant, Stor As Variant Lille = Array(1, 10, 20, 30, 40, 50, 60, 70, 80) ' mindste værdier Stor = Array(9, 19, 29, 39, 49, 59, 69, 79, 90) ' største værdier
R = 0 T = 0
'****************************** Tilpasser pladen på arket **************** Range("A1:I3").Font.Size = 18 Rows("1:3").RowHeight = 39.75 Selection.RowHeight = 39.75 Range("A1:I3").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With Range("A1").Select '*********************************** Tilpasser pladen slut ****************
A = Int(Rnd * 9) + 1 ' Randum fordeling '****************************** Tilpasser Antal på pladen **************** Select Case A Case 1 R1 = Array(2, 1, 2, 1, 3, 2, 2, 1, 1) Case 2 R1 = Array(1, 1, 3, 2, 1, 1, 2, 3, 1) Case 3 R1 = Array(1, 2, 1, 3, 1, 2, 1, 2, 2) Case 4 R1 = Array(2, 2, 1, 1, 1, 1, 3, 2, 2) Case 5 R1 = Array(1, 2, 2, 1, 3, 2, 2, 1, 1) Case 6 R1 = Array(3, 2, 1, 2, 2, 2, 1, 1, 1) Case 7 R1 = Array(1, 2, 2, 2, 1, 3, 1, 1, 2) Case 8 R1 = Array(3, 1, 2, 2, 1, 1, 2, 1, 2) Case 9 R1 = Array(1, 2, 1, 1, 2, 1, 1, 3, 3) End Select '****************************** Tilpasser Antal slut ****************
For T = 0 To 8 ' 9 kolonner R = R + 1 For I = 1 To 3 ' antal rækker
Start1: U = Int(Rnd * 3) + 1 'tilfældig placering på række UU(I) = U For Y = 1 To I - 1 If UU(Y) = U Then GoTo Start1 Next Y Start2: X = Int((Rnd() * (Stor(T) - Lille(T)) + Lille(T))) If U > R1(T) Then Cells(I, R).Font.Size = 10 ' ændre tekststørrelsen på bart felt Cells(I, R) = "kabbak" ' bart felt GoTo BarFelt End If
For Y = 1 To I - 1 If C(Y) = X Then GoTo Start2 Next Y C(Y) = X Cells(I, R) = X
Public Sub BingoPlader() Dim C(3) As Variant, UU(3) As Integer, X As Variant, U As Integer, I As Integer, Lille As Variant, Stor As Variant Dim NyPlade As Integer Columns("A:K").Clear Q = InputBox(" indtast antal plader", "Antal plader", 1) Application.ScreenUpdating = False Lille = Array(1, 10, 20, 30, 40, 50, 60, 70, 80) ' mindste værdier Stor = Array(9, 19, 29, 39, 49, 59, 69, 79, 90) ' største værdier NyPlade = 2 R = 1 T = 0
'****************************** Tilpasser pladen på arket ****************
If Sideskift = 5 Then Sideskift = 0 Rows(NyPlade + 4).RowHeight = 20 Range(Cells(NyPlade + 4, 1), Cells(NyPlade + 4, 11)).Interior.ColorIndex = 40 NyPlade = NyPlade + 5 Else NyPlade = NyPlade + 4 End If Next Range(Cells(1, 1), Cells(NyPlade - 1, 1)).Interior.ColorIndex = 40 Range(Cells(1, 11), Cells(NyPlade - 1, 11)).Interior.ColorIndex = 40 Range("A1").Select '*********************************** Tilpasser pladen slut **************** NyPlade = 2 Sideskift = 0 For ny = 1 To Q Sideskift = Sideskift + 1 A = Int(Rnd * 9) + 1 ' Randum fordeling '****************************** Tilpasser Antal på pladen **************** Select Case A Case 1 R1 = Array(2, 1, 2, 1, 3, 2, 2, 1, 1) Case 2 R1 = Array(1, 1, 3, 2, 1, 1, 2, 3, 1) Case 3 R1 = Array(1, 2, 1, 3, 1, 2, 1, 2, 2) Case 4 R1 = Array(2, 2, 1, 1, 1, 1, 3, 2, 2) Case 5 R1 = Array(1, 2, 2, 1, 3, 2, 2, 1, 1) Case 6 R1 = Array(3, 2, 1, 2, 2, 2, 1, 1, 1) Case 7 R1 = Array(1, 2, 2, 2, 1, 3, 1, 1, 2) Case 8 R1 = Array(3, 1, 2, 2, 1, 1, 2, 1, 2) Case 9 R1 = Array(1, 2, 1, 1, 2, 1, 1, 3, 3) End Select '****************************** Tilpasser Antal slut ****************
For T = 0 To 8 ' 9 kolonner R = R + 1 For I = 1 To 3 ' antal rækker
Start1: U = Int(Rnd * 3) + 1 'tilfældig placering på række UU(I) = U For Y = 1 To I - 1 If UU(Y) = U Then GoTo Start1 Next Y Start2: X = Int((Rnd() * (Stor(T) - Lille(T)) + Lille(T))) If U > R1(T) Then Cells(I + (NyPlade - 1), R).Font.Size = 10 ' ændre tekststørrelsen på bart felt Cells(I + (NyPlade - 1), R) = "kabbak" ' bart felt GoTo BarFelt End If
For Y = 1 To I - 1 If C(Y) = X Then GoTo Start2 Next Y C(Y) = X Cells(I + (NyPlade - 1), R) = X
BarFelt: Next I '**************************** sortering ************** For I = 1 To 3 If Cells(I + (NyPlade - 1), R).Font.Size = 10 Then GoTo Tekst1
For IV = 1 To 2 If Cells(IV + (NyPlade - 1), R).Font.Size = 10 Then GoTo Tekst2
If Cells(I + (NyPlade - 1), R) < Cells(IV + (NyPlade - 1), R) Then temp = Cells(I + (NyPlade - 1), R) Cells(I + (NyPlade - 1), R) = Cells(IV + (NyPlade - 1), R) Cells(IV + (NyPlade - 1), R) = temp End If Tekst2: Next IV Tekst1: Next I
'**************************** sortering slut ************** Next T If Sideskift = 5 Then Sideskift = 0 NyPlade = NyPlade + 5 Else NyPlade = NyPlade + 4 End If
R = 1 Next ny Application.ScreenUpdating = True End Sub
Public Sub BingoPlader() Dim C(3) As Variant, UU(3) As Integer, X As Variant, U As Integer, I As Integer, Lille As Variant, Stor As Variant Dim NyPlade As Integer Columns("A:K").Clear Q = InputBox(" indtast antal plader", "Antal plader", 1) Application.ScreenUpdating = False Lille = Array(1, 10, 20, 30, 40, 50, 60, 70, 80) ' mindste værdier Stor = Array(9, 19, 29, 39, 49, 59, 69, 79, 90) ' største værdier NyPlade = 2 R = 1 T = 0
'****************************** Tilpasser pladen på arket ****************
If Sideskift = 5 Then If I = Q Then NyPlade = NyPlade + 4 Else Sideskift = 0 Rows(NyPlade + 4).RowHeight = 20 Range(Cells(NyPlade + 4, 1), Cells(NyPlade + 4, 11)).Interior.ColorIndex = 40 NyPlade = NyPlade + 5 End If Else NyPlade = NyPlade + 4 End If Next Range(Cells(1, 1), Cells(NyPlade - 1, 1)).Interior.ColorIndex = 40 Range(Cells(1, 11), Cells(NyPlade - 1, 11)).Interior.ColorIndex = 40 Range("A1").Select '*********************************** Tilpasser pladen slut **************** NyPlade = 2 Sideskift = 0 For ny = 1 To Q Sideskift = Sideskift + 1 A = Int(Rnd * 9) + 1 ' Randum fordeling '****************************** Tilpasser Antal på pladen **************** Select Case A Case 1 R1 = Array(2, 1, 2, 1, 3, 2, 2, 1, 1) Case 2 R1 = Array(1, 1, 3, 2, 1, 1, 2, 3, 1) Case 3 R1 = Array(1, 2, 1, 3, 1, 2, 1, 2, 2) Case 4 R1 = Array(2, 2, 1, 1, 1, 1, 3, 2, 2) Case 5 R1 = Array(1, 2, 2, 1, 3, 2, 2, 1, 1) Case 6 R1 = Array(3, 2, 1, 2, 2, 2, 1, 1, 1) Case 7 R1 = Array(1, 2, 2, 2, 1, 3, 1, 1, 2) Case 8 R1 = Array(3, 1, 2, 2, 1, 1, 2, 1, 2) Case 9 R1 = Array(1, 2, 1, 1, 2, 1, 1, 3, 3) End Select '****************************** Tilpasser Antal slut ****************
For T = 0 To 8 ' 9 kolonner R = R + 1 For I = 1 To 3 ' antal rækker
Start1: U = Int(Rnd * 3) + 1 'tilfældig placering på række UU(I) = U For Y = 1 To I - 1 If UU(Y) = U Then GoTo Start1 Next Y Start2: X = Int((Rnd() * (Stor(T) - Lille(T)) + Lille(T))) If U > R1(T) Then Cells(I + (NyPlade - 1), R).Font.Size = 10 ' ændre tekststørrelsen på bart felt Cells(I + (NyPlade - 1), R) = "kabbak" ' bart felt GoTo BarFelt End If
For Y = 1 To I - 1 If C(Y) = X Then GoTo Start2 Next Y C(Y) = X Cells(I + (NyPlade - 1), R) = X
BarFelt: Next I '**************************** sortering ************** For I = 1 To 3 If Cells(I + (NyPlade - 1), R).Font.Size = 10 Then GoTo Tekst1
For IV = 1 To 2 If Cells(IV + (NyPlade - 1), R).Font.Size = 10 Then GoTo Tekst2
If Cells(I + (NyPlade - 1), R) < Cells(IV + (NyPlade - 1), R) Then temp = Cells(I + (NyPlade - 1), R) Cells(I + (NyPlade - 1), R) = Cells(IV + (NyPlade - 1), R) Cells(IV + (NyPlade - 1), R) = temp End If Tekst2: Next IV Tekst1: Next I
'**************************** sortering slut ************** Next T If Sideskift = 5 Then Sideskift = 0 NyPlade = NyPlade + 5 Else NyPlade = NyPlade + 4 End If
R = 1 Next ny Application.ScreenUpdating = True End Sub
Den var ikke færdig alligevel, jeg glemte det med 5 på hver række.
Så det er den nu.
Public Sub BingoPlader() Dim C(3) As Variant, UU(3) As Integer, X As Variant, U As Integer, I As Integer, Lille As Variant, Stor As Variant Dim NyPlade As Integer, Rcount(2) As Integer
LilleTekst = 10 ' ret Font Size her for lille skrift StorTekst = 24 ' ret Font Size her for stor skrift BlankFeltTekst = "kabbak" ' ret blank felt tekst her Kantfarve = 40 'Ret kantfarver her
Columns("A:K").Clear Q = InputBox("indtast antal plader", "Antal plader", 1) ' antal plader, 5 på hvert A4 ark Application.ScreenUpdating = False ' slår skærm opdateringen fra Lille = Array(1, 10, 20, 30, 40, 50, 60, 70, 80) ' mindste værdier Stor = Array(9, 19, 29, 39, 49, 59, 69, 79, 90) ' største værdier NyPlade = 2 R = 1 T = 0
'****************************** Tilpasser pladen på arket ****************
If Sideskift = 5 Then If I = Q Then NyPlade = NyPlade + 4 Else Sideskift = 0 Rows(NyPlade + 4).RowHeight = 20 Range(Cells(NyPlade + 4, 1), Cells(NyPlade + 4, 11)).Interior.ColorIndex = Kantfarve NyPlade = NyPlade + 5 End If Else NyPlade = NyPlade + 4 End If Next Range(Cells(1, 1), Cells(NyPlade - 1, 1)).Interior.ColorIndex = Kantfarve Range(Cells(1, 11), Cells(NyPlade - 1, 11)).Interior.ColorIndex = Kantfarve Range("A1").Select '*********************************** Tilpasser pladen slut **************** NyPlade = 2 Sideskift = 0 For ny = 1 To Q Sideskift = Sideskift + 1 A = Int(Rnd * 9) + 1 ' Randum fordeling '****************************** Tilpasser Antal på pladen **************** Select Case A Case 1 R1 = Array(2, 1, 2, 1, 3, 2, 2, 1, 1) Case 2 R1 = Array(1, 1, 3, 2, 1, 1, 2, 3, 1) Case 3 R1 = Array(1, 2, 1, 3, 1, 2, 1, 2, 2) Case 4 R1 = Array(2, 2, 1, 1, 1, 1, 3, 2, 2) Case 5 R1 = Array(1, 2, 2, 1, 3, 2, 2, 1, 1) Case 6 R1 = Array(3, 2, 1, 2, 2, 2, 1, 1, 1) Case 7 R1 = Array(1, 2, 2, 2, 1, 3, 1, 1, 2) Case 8 R1 = Array(3, 1, 2, 2, 1, 1, 2, 1, 2) Case 9 R1 = Array(1, 2, 1, 1, 2, 1, 1, 3, 3) End Select '****************************** Tilpasser Antal slut ****************
For T = 0 To 8 ' 9 kolonner R = R + 1 For I = 1 To 3 ' antal rækker
Start1: U = Int(Rnd * 3) + 1 'tilfældig placering på række UU(I) = U For Y = 1 To I - 1 If UU(Y) = U Then GoTo Start1 Next Y Start2: X = Int((Rnd() * (Stor(T) - Lille(T) + 1) + Lille(T))) If U > R1(T) Then Cells(I + (NyPlade - 1), R).Font.Size = LilleTekst ' ændre tekststørrelsen på bart felt Cells(I + (NyPlade - 1), R) = BlankFeltTekst ' bart felt GoTo BarFelt End If
For Y = 1 To I - 1 If C(Y) = X Then GoTo Start2 Next Y C(Y) = X Cells(I + (NyPlade - 1), R) = X
BarFelt: Next I '**************************** sortering lodret stigende ************** For I = 1 To 3 If Cells(I + (NyPlade - 1), R).Font.Size = LilleTekst Then GoTo Tekst1
For Iv = 1 To 2 If Cells(Iv + (NyPlade - 1), R).Font.Size = LilleTekst Then GoTo Tekst2 If Cells(I + (NyPlade - 1), R) < Cells(Iv + (NyPlade - 1), R) Then temp = Cells(I + (NyPlade - 1), R) Cells(I + (NyPlade - 1), R) = Cells(Iv + (NyPlade - 1), R) Cells(Iv + (NyPlade - 1), R) = temp End If Tekst2: Next Iv Tekst1: Next I Next T '**************************** sortering 5 i hver række **************
TjekIgen:
For I = 0 To 2 Rcount(I) = 0 For Each NR In Range(Cells(NyPlade + I, 2), Cells(NyPlade + I, 10)) If IsNumeric(NR) Then Rcount(I) = Rcount(I) + 1 End If Next Next If Rcount(0) < 5 And Rcount(1) > 5 Then fra = 1: Til = 0: GoTo FlytPlads If Rcount(0) < 5 And Rcount(2) > 5 Then fra = 2: Til = 0: GoTo FlytPlads If Rcount(1) < 5 And Rcount(0) > 5 Then fra = 0: Til = 1: GoTo FlytPlads If Rcount(1) < 5 And Rcount(2) > 5 Then fra = 2: Til = 1: GoTo FlytPlads If Rcount(2) < 5 And Rcount(0) > 5 Then fra = 0: Til = 2: GoTo FlytPlads If Rcount(2) < 5 And Rcount(1) > 5 Then fra = 1: Til = 2: GoTo FlytPlads GoTo AltOk FlytPlads: For Iv = 1 To 9 If IsNumeric(Cells(NyPlade + fra, Iv + 1)) Then ' rækken med mere end 5 If Cells(NyPlade + Til, Iv + 1) = BlankFeltTekst Then 'rækken med mindre end 5 og skal være blank Cells(NyPlade + Til, Iv + 1) = Cells(NyPlade + fra, Iv + 1) ' flytter række Cells(NyPlade + Til, Iv + 1).Font.Size = StorTekst ' ændrer skriftstørrelse Cells(NyPlade + fra, Iv + 1) = BlankFeltTekst ' skriver blank tekst Cells(NyPlade + fra, Iv + 1).Font.Size = LilleTekst ' ændrer skriftstørrelse på blank GoTo TjekIgen End If End If Next GoTo TjekIgen '**************************** sortering slut ************** AltOk: If Sideskift = 5 Then Sideskift = 0 NyPlade = NyPlade + 5 Else NyPlade = NyPlade + 4 End If R = 1 Next ny Application.ScreenUpdating = True End Sub
Den sorterede ikke ordentlig, så det er sidste bud fra mig.
Men hvis nogen kunne opdater sorteringen så den blev hurtigere, vil jeg da gerne høre nærmere.
Public Sub BingoPlader() Dim C(3) As Variant, UU(3) As Integer, X As Variant, U As Integer, I As Integer, Lille As Variant, Stor As Variant Dim NyPlade As Integer, Rcount(2) As Integer
LilleTekst = 10 ' ret Font Size her for lille skrift StorTekst = 24 ' ret Font Size her for stor skrift BlankFeltTekst = "kabbak" ' ret blank felt tekst her Kantfarve = 40 'Ret kantfarver her
Columns("A:K").Clear Q = InputBox("indtast antal plader", "Antal plader", 1) ' antal plader, 5 på hvert A4 ark Application.ScreenUpdating = False ' slår skærm opdateringen fra Lille = Array(1, 10, 20, 30, 40, 50, 60, 70, 80) ' mindste værdier Stor = Array(9, 19, 29, 39, 49, 59, 69, 79, 90) ' største værdier NyPlade = 2 R = 1 T = 0
'****************************** Tilpasser pladen på arket ****************
If Sideskift = 5 Then If I = Q Then NyPlade = NyPlade + 4 Else Sideskift = 0 Rows(NyPlade + 4).RowHeight = 20 Range(Cells(NyPlade + 4, 1), Cells(NyPlade + 4, 11)).Interior.ColorIndex = Kantfarve NyPlade = NyPlade + 5 End If Else NyPlade = NyPlade + 4 End If Next Range(Cells(1, 1), Cells(NyPlade - 1, 1)).Interior.ColorIndex = Kantfarve Range(Cells(1, 11), Cells(NyPlade - 1, 11)).Interior.ColorIndex = Kantfarve Range("A1").Select '*********************************** Tilpasser pladen slut **************** NyPlade = 2 Sideskift = 0 For ny = 1 To Q Sideskift = Sideskift + 1 A = Int(Rnd * 9) + 1 ' Randum fordeling '****************************** Tilpasser Antal på pladen **************** Select Case A Case 1 R1 = Array(2, 1, 2, 1, 3, 2, 2, 1, 1) Case 2 R1 = Array(1, 1, 3, 2, 1, 1, 2, 3, 1) Case 3 R1 = Array(1, 2, 1, 3, 1, 2, 1, 2, 2) Case 4 R1 = Array(2, 2, 1, 1, 1, 1, 3, 2, 2) Case 5 R1 = Array(1, 2, 2, 1, 3, 2, 2, 1, 1) Case 6 R1 = Array(3, 2, 1, 2, 2, 2, 1, 1, 1) Case 7 R1 = Array(1, 2, 2, 2, 1, 3, 1, 1, 2) Case 8 R1 = Array(3, 1, 2, 2, 1, 1, 2, 1, 2) Case 9 R1 = Array(1, 2, 1, 1, 2, 1, 1, 3, 3) End Select '****************************** Tilpasser Antal slut ****************
For T = 0 To 8 ' 9 kolonner R = R + 1 For I = 1 To 3 ' antal rækker
Start1: U = Int(Rnd * 3) + 1 'tilfældig placering på række UU(I) = U For Y = 1 To I - 1 If UU(Y) = U Then GoTo Start1 Next Y Start2: X = Int((Rnd() * (Stor(T) - Lille(T) + 1) + Lille(T))) If U > R1(T) Then Cells(I + (NyPlade - 1), R).Font.Size = LilleTekst ' ændre tekststørrelsen på bart felt Cells(I + (NyPlade - 1), R) = BlankFeltTekst ' bart felt GoTo BarFelt End If
For Y = 1 To I - 1 If C(Y) = X Then GoTo Start2 Next Y C(Y) = X Cells(I + (NyPlade - 1), R) = X
BarFelt: Next I Next T '**************************** sortering 5 i hver række ************** TjekIgen:
For I = 0 To 2 Rcount(I) = 0 For Each NR In Range(Cells(NyPlade + I, 2), Cells(NyPlade + I, 10)) If IsNumeric(NR) Then Rcount(I) = Rcount(I) + 1 End If Next Next If Rcount(0) < 5 And Rcount(1) > 5 Then Fra = 1: Til = 0: GoTo FlytPlads If Rcount(0) < 5 And Rcount(2) > 5 Then Fra = 2: Til = 0: GoTo FlytPlads If Rcount(1) < 5 And Rcount(0) > 5 Then Fra = 0: Til = 1: GoTo FlytPlads If Rcount(1) < 5 And Rcount(2) > 5 Then Fra = 2: Til = 1: GoTo FlytPlads If Rcount(2) < 5 And Rcount(0) > 5 Then Fra = 0: Til = 2: GoTo FlytPlads If Rcount(2) < 5 And Rcount(1) > 5 Then Fra = 1: Til = 2: GoTo FlytPlads GoTo AltOk
FlytPlads: For Iv = 2 To 10 If IsNumeric(Cells(NyPlade + Fra, Iv)) Then ' rækken med mere end 5 If Cells(NyPlade + Til, Iv) = BlankFeltTekst Then 'rækken med mindre end 5 og skal være blank
Cells(NyPlade + Til, Iv) = Cells(NyPlade + Fra, Iv) ' flytter række Cells(NyPlade + Fra, Iv) = BlankFeltTekst ' skriver blank tekst
End If End If Next GoTo TjekIgen '**************************** sortering lodret stigende ************** AltOk: For v = 2 To 10 For I = 1 To 3 If Cells(I + (NyPlade - 1), v).Font.Size = LilleTekst Then GoTo Tekst1
For Iv = 1 To 2 If Cells(Iv + (NyPlade - 1), v).Font.Size = LilleTekst Then GoTo Tekst2 If Cells(I + (NyPlade - 1), v) < Cells(Iv + (NyPlade - 1), v) Then temp = Cells(I + (NyPlade - 1), v) Cells(I + (NyPlade - 1), v) = Cells(Iv + (NyPlade - 1), v) Cells(Iv + (NyPlade - 1), v) = temp End If Tekst2: Next Iv Tekst1: Next I Next
'**************************** sortering slut **************
If Sideskift = 5 Then Sideskift = 0 NyPlade = NyPlade + 5 Else NyPlade = NyPlade + 4 End If R = 1 Next ny Application.ScreenUpdating = True End Sub
Jeg kan kun give bak ret - flot arbejde! Selvom reglerne for en bankoplade er forholdsvis simple, kan man hurtigt regne ud, at det hurtigt bliver kompliceret. Jeg har faktisk set programmer, som laver et A4-ark med 6 plader, hvor samtlige 90 tal forekommer én gang.
Har jeg ret i, at jeg kan udvide området
A = Int(Rnd * 9) + 1 ' Randum fordeling '****************************** Tilpasser Antal på pladen **************** Select Case A Case 1 R1 = Array(2, 1, 2, 1, 3, 2, 2, 1, 1)
med flere arrays, så det f.eks. også er muligt, at der kan forekomme 3 tal på en plade mellem 20 og 29?
Hvordan vil koden så se ud? Tanken om, at det er totalt tilfældigt tiltaler mig :-) Jeg har set en beregning som siger, at der skulle være 3.669688.706217.187500 (3 trilliareder) kombinationsmuligheder, eller nok til, at alle mennesker på jorden kan få ca. 500 millioner forskellige plader hver.
Public Sub BingoPlader() Dim C(3) As Variant, UU(3) As Integer, X As Variant, U As Integer, I As Integer, Lille As Variant, Stor As Variant Dim NyPlade As Integer, Rcount(2) As Integer, Kol(9) As Integer Randomize LilleTekst = 10 ' ret Font Size her for lille skrift StorTekst = 24 ' ret Font Size her for stor skrift BlankFeltTekst = "kabbak" ' ret blank felt tekst her Kantfarve = 40 'Ret kantfarver her
Columns("A:K").Clear Q = InputBox("indtast antal plader", "Antal plader", 1) ' antal plader, 5 på hvert A4 ark Application.ScreenUpdating = False ' slår skærm opdateringen fra Lille = Array(1, 10, 20, 30, 40, 50, 60, 70, 80) ' mindste værdier Stor = Array(9, 19, 29, 39, 49, 59, 69, 79, 90) ' største værdier NyPlade = 2 R = 1 t = 0
'****************************** Tilpasser pladen på arket ****************
If Sideskift = 5 Then If I = Q Then NyPlade = NyPlade + 4 Else Sideskift = 0 Rows(NyPlade + 4).RowHeight = 20 Range(Cells(NyPlade + 4, 1), Cells(NyPlade + 4, 11)).Interior.ColorIndex = Kantfarve NyPlade = NyPlade + 5 End If Else NyPlade = NyPlade + 4 End If Next Range(Cells(1, 1), Cells(NyPlade - 1, 1)).Interior.ColorIndex = Kantfarve Range(Cells(1, 11), Cells(NyPlade - 1, 11)).Interior.ColorIndex = Kantfarve Range("A1").Select '*********************************** Tilpasser pladen slut **************** NyPlade = 2 Sideskift = 0 For ny = 1 To Q Sideskift = Sideskift + 1 A = Int(Rnd * 9) + 1 ' Randum fordeling '****************************** Tilpasser Antal på pladen **************** Select Case A Case 1 R1 = Array(2, 1, 2, 1, 3, 2, 2, 1, 1) Case 2 R1 = Array(1, 1, 3, 2, 1, 1, 2, 3, 1) Case 3 R1 = Array(1, 2, 1, 3, 1, 2, 1, 2, 2) Case 4 R1 = Array(2, 2, 1, 1, 1, 1, 3, 2, 2) Case 5 R1 = Array(1, 2, 2, 1, 3, 2, 2, 1, 1) Case 6 R1 = Array(3, 2, 1, 2, 2, 2, 1, 1, 1) Case 7 R1 = Array(1, 2, 2, 2, 1, 3, 1, 1, 2) Case 8 R1 = Array(3, 1, 2, 2, 1, 1, 2, 1, 2) Case 9 R1 = Array(1, 2, 1, 1, 2, 1, 1, 3, 3) End Select '****************************** Tilpasser Antal slut ****************
For t = 1 To 9 ' 9 kolonner KOL1: UK = Int(Rnd * 9) + 1 'tilfældig placering på Kolonner Kol(t) = UK For Y = 1 To t - 1 If Kol(Y) = UK Then GoTo KOL1 Next Y R = UK + 1
For I = 1 To 3 ' antal rækker
Start1: U = Int(Rnd * 3) + 1 'tilfældig placering på række UU(I) = U For Y = 1 To I - 1 If UU(Y) = U Then GoTo Start1 Next Y Start2: X = Int((Rnd() * (Stor(UK - 1) - Lille(UK - 1) + 1) + Lille(UK - 1))) If U > R1(UK - 1) Then Cells(I + (NyPlade - 1), R).Font.Size = LilleTekst ' ændre tekststørrelsen på bart felt Cells(I + (NyPlade - 1), R) = BlankFeltTekst ' bart felt GoTo BarFelt End If
For Y = 1 To I - 1 If C(Y) = X Then GoTo Start2 Next Y C(Y) = X Cells(I + (NyPlade - 1), R) = X
BarFelt: Next I Next t '**************************** sortering 5 i hver række ************** TjekIgen:
For I = 0 To 2 Rcount(I) = 0 For Each NR In Range(Cells(NyPlade + I, 2), Cells(NyPlade + I, 10)) If IsNumeric(NR) Then Rcount(I) = Rcount(I) + 1 End If Next Next If Rcount(0) < 5 And Rcount(1) > 5 Then Fra = 1: Til = 0: GoTo FlytPlads If Rcount(0) < 5 And Rcount(2) > 5 Then Fra = 2: Til = 0: GoTo FlytPlads If Rcount(1) < 5 And Rcount(0) > 5 Then Fra = 0: Til = 1: GoTo FlytPlads If Rcount(1) < 5 And Rcount(2) > 5 Then Fra = 2: Til = 1: GoTo FlytPlads If Rcount(2) < 5 And Rcount(0) > 5 Then Fra = 0: Til = 2: GoTo FlytPlads If Rcount(2) < 5 And Rcount(1) > 5 Then Fra = 1: Til = 2: GoTo FlytPlads GoTo AltOk
FlytPlads: For Iv = 2 To 10 If IsNumeric(Cells(NyPlade + Fra, Iv)) Then ' rækken med mere end 5 If Cells(NyPlade + Til, Iv) = BlankFeltTekst Then 'rækken med mindre end 5 og skal være blank
Cells(NyPlade + Til, Iv) = Cells(NyPlade + Fra, Iv) ' flytter række Cells(NyPlade + Fra, Iv) = BlankFeltTekst ' skriver blank tekst
End If End If Next GoTo TjekIgen '**************************** sortering lodret stigende ************** AltOk: For v = 2 To 10 For I = 1 To 3 If Cells(I + (NyPlade - 1), v).Font.Size = LilleTekst Then GoTo Tekst1
For Iv = 1 To 2 If Cells(Iv + (NyPlade - 1), v).Font.Size = LilleTekst Then GoTo Tekst2 If Cells(I + (NyPlade - 1), v) < Cells(Iv + (NyPlade - 1), v) Then temp = Cells(I + (NyPlade - 1), v) Cells(I + (NyPlade - 1), v) = Cells(Iv + (NyPlade - 1), v) Cells(Iv + (NyPlade - 1), v) = temp End If Tekst2: Next Iv Tekst1: Next I Next
'**************************** sortering slut **************
If Sideskift = 5 Then Sideskift = 0 NyPlade = NyPlade + 5 Else NyPlade = NyPlade + 4 End If R = 1 Next ny Application.ScreenUpdating = True End Sub
Hvis den fordeler dem tilfældigt på kolonnerne, er der så vidt jeg kan se kun behov for 4 kombinationsmuligheder: 3 3 3 1 1 1 1 1 1 3 3 2 2 1 1 1 1 1 3 2 2 2 2 1 1 1 1 2 2 2 2 2 2 1 1 1
nu har jeg haft 3 tal i alle kolonner, mon ikke så det dur.
Public Sub BingoPlader() Dim C(3) As Variant, UU(3) As Integer, X As Variant, U As Integer, I As Integer, Lille As Variant, Stor As Variant Dim NyPlade As Integer, Rcount(2) As Integer, Kol(8) As Integer Randomize LilleTekst = 10 ' ret Font Size her for lille skrift StorTekst = 24 ' ret Font Size her for stor skrift BlankFeltTekst = "kabbak" ' ret blank felt tekst her Kantfarve = 40 'Ret kantfarver her
Columns("A:K").Clear Q = InputBox("indtast antal plader", "Antal plader", 1) ' antal plader, 5 på hvert A4 ark Application.ScreenUpdating = False ' slår skærm opdateringen fra Lille = Array(1, 10, 20, 30, 40, 50, 60, 70, 80) ' mindste værdier Stor = Array(9, 19, 29, 39, 49, 59, 69, 79, 90) ' største værdier NyPlade = 2 R = 1 T = 0
'****************************** Tilpasser pladen på arket ****************
If Sideskift = 5 Then If I = Q Then NyPlade = NyPlade + 4 Else Sideskift = 0 Rows(NyPlade + 4).RowHeight = 20 Range(Cells(NyPlade + 4, 1), Cells(NyPlade + 4, 11)).Interior.ColorIndex = Kantfarve NyPlade = NyPlade + 5 End If Else NyPlade = NyPlade + 4 End If Next Range(Cells(1, 1), Cells(NyPlade - 1, 1)).Interior.ColorIndex = Kantfarve Range(Cells(1, 11), Cells(NyPlade - 1, 11)).Interior.ColorIndex = Kantfarve Range("A1").Select '*********************************** Tilpasser pladen slut **************** NyPlade = 2 Sideskift = 0 For ny = 1 To Q Sideskift = Sideskift + 1 A = Int(Rnd * 9) + 1 ' Randum fordeling '****************************** Tilpasser Antal på pladen **************** Select Case A Case 1 R1 = Array(2, 1, 2, 1, 3, 2, 2, 1, 1) Case 2 R1 = Array(1, 1, 3, 2, 1, 1, 2, 3, 1) Case 3 R1 = Array(1, 2, 1, 3, 1, 2, 1, 2, 2) Case 4 R1 = Array(2, 2, 1, 1, 1, 1, 3, 2, 2) Case 5 R1 = Array(1, 2, 2, 1, 3, 2, 2, 1, 1) Case 6 R1 = Array(3, 2, 1, 2, 2, 2, 1, 1, 1) Case 7 R1 = Array(1, 2, 2, 2, 1, 3, 1, 1, 2) Case 8 R1 = Array(3, 1, 2, 2, 1, 1, 2, 1, 2) Case 9 R1 = Array(1, 2, 1, 1, 2, 1, 1, 3, 3) End Select '****************************** Tilpasser Antal slut **************** '****************************** Blanding start **************** For T = 0 To 8 ' 9 kolonner KOL1: UK = Int(Rnd * 9) + 1 'tilfældig placering på Kolonner Kol(T) = UK - 1 For Y = 0 To T - 1 If Kol(Y) = UK - 1 Then GoTo KOL1 Next Y Next T '****************************** Blanding ****************
For T = 0 To 8 ' 9 kolonner R = R + 1 For I = 1 To 3 ' antal rækker
Start1: U = Int(Rnd * 3) + 1 'tilfældig placering på række UU(I) = U For Y = 1 To I - 1 If UU(Y) = U Then GoTo Start1 Next Y Start2: X = Int((Rnd() * (Stor(T) - Lille(T) + 1) + Lille(T))) If U > R1(Kol(T)) Then Cells(I + (NyPlade - 1), R).Font.Size = LilleTekst ' ændre tekststørrelsen på bart felt Cells(I + (NyPlade - 1), R) = BlankFeltTekst ' bart felt GoTo BarFelt End If
For Y = 1 To I - 1 If C(Y) = X Then GoTo Start2 Next Y C(Y) = X Cells(I + (NyPlade - 1), R) = X
BarFelt: Next I Next T '**************************** sortering 5 i hver række ************** TjekIgen:
For I = 0 To 2 Rcount(I) = 0 For Each NR In Range(Cells(NyPlade + I, 2), Cells(NyPlade + I, 10)) If IsNumeric(NR) Then Rcount(I) = Rcount(I) + 1 End If Next Next If Rcount(0) < 5 And Rcount(1) > 5 Then Fra = 1: Til = 0: GoTo FlytPlads If Rcount(0) < 5 And Rcount(2) > 5 Then Fra = 2: Til = 0: GoTo FlytPlads If Rcount(1) < 5 And Rcount(0) > 5 Then Fra = 0: Til = 1: GoTo FlytPlads If Rcount(1) < 5 And Rcount(2) > 5 Then Fra = 2: Til = 1: GoTo FlytPlads If Rcount(2) < 5 And Rcount(0) > 5 Then Fra = 0: Til = 2: GoTo FlytPlads If Rcount(2) < 5 And Rcount(1) > 5 Then Fra = 1: Til = 2: GoTo FlytPlads GoTo AltOk
FlytPlads: For Iv = 2 To 10 If IsNumeric(Cells(NyPlade + Fra, Iv)) Then ' rækken med mere end 5 If Cells(NyPlade + Til, Iv) = BlankFeltTekst Then 'rækken med mindre end 5 og skal være blank
Cells(NyPlade + Til, Iv) = Cells(NyPlade + Fra, Iv) ' flytter række Cells(NyPlade + Fra, Iv) = BlankFeltTekst ' skriver blank tekst
End If End If Next GoTo TjekIgen '**************************** sortering lodret stigende ************** AltOk: For v = 2 To 10 For I = 1 To 3 If Cells(I + (NyPlade - 1), v).Font.Size = LilleTekst Then GoTo Tekst1
For Iv = 1 To 2 If Cells(Iv + (NyPlade - 1), v).Font.Size = LilleTekst Then GoTo Tekst2 If Cells(I + (NyPlade - 1), v) < Cells(Iv + (NyPlade - 1), v) Then temp = Cells(I + (NyPlade - 1), v) Cells(I + (NyPlade - 1), v) = Cells(Iv + (NyPlade - 1), v) Cells(Iv + (NyPlade - 1), v) = temp End If Tekst2: Next Iv Tekst1: Next I Next
'**************************** sortering slut **************
If Sideskift = 5 Then Sideskift = 0 NyPlade = NyPlade + 5 Else NyPlade = NyPlade + 4 End If R = 1 Next ny Application.ScreenUpdating = True End Sub
ja det ville jo være dejligt, men jeg kan ikke lige overskue hvordan jeg styrer antallet af tal, der må jo kun være 15, det er derfor jeg bruger Case sætningen.
Det er stadig ikke helt tilfældigt. Jeg beklager min stædighed, men hvis det kan lade sig gøre, at lave det helt tilfældigt, kan vi lige så godt lave det.
Der er stadig tilladte kombinationer, som koden aldrig vil generere. F.eks. vil der aldrig være 3 kolonner med 3 tal eller en plade uden en kolonne med 3 tal.
Jeg har prøvet at erstatte de 9 "Cases" med de 4 teoretisk mulige, altså: A = Int(Rnd * 4) + 1 ' Randum fordeling Select Case A Case 1 R1 = Array(3, 3, 3, 1, 1, 1, 1, 1, 1) Case 2 R1 = Array(3, 3, 2, 2, 1, 1, 1, 1, 1) Case 3 R1 = Array(3, 2, 2, 2, 2, 1, 1, 1, 1) Case 4 R1 = Array(2, 2, 2, 2, 2, 2, 1, 1, 1) End Select
På denne måde vil alle kombinationer kunne forekomme, men der vil være et forkert forhold mellem dem, f.eks. vil der forekomme 25% af plader med 3 kolonner med 3 tal, hvilket er alt for meget.
Jeg har regnet ud, at der er 1554 kombinationsmuligheder af de 4 cases. Sandsynlighed for Case 1 udgør 84 / 1554 = 5,41% Sandsynlighed for Case 2 udgør 756 / 1554 = 48,65% Sandsynlighed for Case 3 udgør 630 / 1554 = 40,54% Sandsynlighed for Case 4 udgør 84 / 1554 = 5,41%
Hvordan får jeg disse forhold indarbejdet i koden?
Som det er med koden: A = Int(Rnd * 4) + 1 ' Randum fordeling Select Case A Case 1 R1 = Array(3, 3, 3, 1, 1, 1, 1, 1, 1) Case 2 R1 = Array(3, 3, 2, 2, 1, 1, 1, 1, 1) Case 3 R1 = Array(3, 2, 2, 2, 2, 1, 1, 1, 1) Case 4 R1 = Array(2, 2, 2, 2, 2, 2, 1, 1, 1) End Select
vil der være 25% chance for hver enkelt case. Det skal der ikke være.
Case 1 skal komme i 84 ud af 1554 = 5,41% Case 2 skal komme i 756 ud af 1554 = 48,65% Case 3 skal komme i 630 ud af 1554 = 40,54% Case 4 skal komme i 84 ud af 1554 = 5,41%
Ford = Int(Rnd * 1554) + 1 ' Random fordeling If Ford < 84 + 756 + 630 + 84 Then a = 4 If Ford < 84 + 756 + 630 Then a = 3 If Ford < 84 + 756 Then a = 2 If Ford < 84 Then a = 1
Select Case a Case 1 R1 = Array(3, 3, 3, 1, 1, 1, 1, 1, 1) Case 2 R1 = Array(3, 3, 2, 2, 1, 1, 1, 1, 1) Case 3 R1 = Array(3, 2, 2, 2, 2, 1, 1, 1, 1) Case 4 R1 = Array(2, 2, 2, 2, 2, 2, 1, 1, 1) End Select
Public Sub BingoPlader() Dim C(3) As Variant, UU(3) As Integer, X As Variant, U As Integer, I As Integer, Lille As Variant, Stor As Variant Dim NyPlade As Integer, Rcount(2) As Integer, Kol(8) As Integer Randomize LilleTekst = 6 ' ret Font Size her for lille skrift StorTekst = 24 ' ret Font Size her for stor skrift BlankFeltTekst = "IM" ' ret blank felt tekst her Kantfarve = 40 ' ret kantfarver her
Columns("A:K").Clear Q = InputBox("indtast antal plader", "Antal plader", 1) ' antal plader, 5 på hvert A4 ark Application.ScreenUpdating = False ' slår skærm opdateringen fra Lille = Array(1, 10, 20, 30, 40, 50, 60, 70, 80) ' mindste værdier Stor = Array(9, 19, 29, 39, 49, 59, 69, 79, 90) ' største værdier NyPlade = 2 R = 1 T = 0
'****************************** Tilpasser pladen på arket ****************
If Sideskift = 5 Then If I = Q Then NyPlade = NyPlade + 4 Else Sideskift = 0 Rows(NyPlade + 4).RowHeight = 20 Range(Cells(NyPlade + 4, 1), Cells(NyPlade + 4, 11)).Interior.ColorIndex = Kantfarve NyPlade = NyPlade + 5 End If Else NyPlade = NyPlade + 4 End If Next Range(Cells(1, 1), Cells(NyPlade - 1, 1)).Interior.ColorIndex = Kantfarve Range(Cells(1, 11), Cells(NyPlade - 1, 11)).Interior.ColorIndex = Kantfarve Range("A1").Select '*********************************** Tilpasser pladen slut **************** NyPlade = 2 Sideskift = 0 For ny = 1 To Q Sideskift = Sideskift + 1
'****************************** Tilpasser Antal på pladen **************** ' De 4 fordelingsmuligheder har forskellige sandsynligheder ' De kan placeres på 1554 forskellige måder
Ford = Int(Rnd * 1554) + 1 ' Random fordeling If Ford < 84 + 756 + 630 + 84 Then a = 4 If Ford < 84 + 756 + 630 Then a = 3 If Ford < 84 + 756 Then a = 2 If Ford < 84 Then a = 1
Select Case a Case 1 R1 = Array(3, 3, 3, 1, 1, 1, 1, 1, 1) Case 2 R1 = Array(3, 3, 2, 2, 1, 1, 1, 1, 1) Case 3 R1 = Array(3, 2, 2, 2, 2, 1, 1, 1, 1) Case 4 R1 = Array(2, 2, 2, 2, 2, 2, 1, 1, 1) End Select '****************************** Blanding start **************** For T = 0 To 8 ' 9 kolonner KOL1: UK = Int(Rnd * 9) + 1 'tilfældig placering på Kolonner Kol(T) = UK - 1 For Y = 0 To T - 1 If Kol(Y) = UK - 1 Then GoTo KOL1 Next Y Next T '****************************** Blanding ****************
For T = 0 To 8 ' 9 kolonner R = R + 1 For I = 1 To 3 ' antal rækker
Start1: U = Int(Rnd * 3) + 1 'tilfældig placering på række UU(I) = U For Y = 1 To I - 1 If UU(Y) = U Then GoTo Start1 Next Y Start2: X = Int((Rnd() * (Stor(T) - Lille(T) + 1) + Lille(T))) If U > R1(Kol(T)) Then Cells(I + (NyPlade - 1), R).Font.Size = LilleTekst ' ændre tekststørrelsen på bart felt Cells(I + (NyPlade - 1), R) = BlankFeltTekst ' bart felt GoTo BarFelt End If
For Y = 1 To I - 1 If C(Y) = X Then GoTo Start2 Next Y C(Y) = X Cells(I + (NyPlade - 1), R) = X
BarFelt: Next I Next T '**************************** sortering 5 i hver række ************** TjekIgen:
For I = 0 To 2 Rcount(I) = 0 For Each NR In Range(Cells(NyPlade + I, 2), Cells(NyPlade + I, 10)) If IsNumeric(NR) Then Rcount(I) = Rcount(I) + 1 End If Next Next If Rcount(0) < 5 And Rcount(1) > 5 Then Fra = 1: Til = 0: GoTo FlytPlads If Rcount(0) < 5 And Rcount(2) > 5 Then Fra = 2: Til = 0: GoTo FlytPlads If Rcount(1) < 5 And Rcount(0) > 5 Then Fra = 0: Til = 1: GoTo FlytPlads If Rcount(1) < 5 And Rcount(2) > 5 Then Fra = 2: Til = 1: GoTo FlytPlads If Rcount(2) < 5 And Rcount(0) > 5 Then Fra = 0: Til = 2: GoTo FlytPlads If Rcount(2) < 5 And Rcount(1) > 5 Then Fra = 1: Til = 2: GoTo FlytPlads GoTo AltOk
FlytPlads: For Iv = 2 To 10 If IsNumeric(Cells(NyPlade + Fra, Iv)) Then ' rækken med mere end 5 If Cells(NyPlade + Til, Iv) = BlankFeltTekst Then 'rækken med mindre end 5 og skal være blank
Cells(NyPlade + Til, Iv) = Cells(NyPlade + Fra, Iv) ' flytter række Cells(NyPlade + Fra, Iv) = BlankFeltTekst ' skriver blank tekst
End If End If Next GoTo TjekIgen '**************************** sortering lodret stigende ************** AltOk: For v = 2 To 10 For I = 1 To 3 If Cells(I + (NyPlade - 1), v).Font.Size = LilleTekst Then GoTo Tekst1
For Iv = 1 To 2 If Cells(Iv + (NyPlade - 1), v).Font.Size = LilleTekst Then GoTo Tekst2 If Cells(I + (NyPlade - 1), v) < Cells(Iv + (NyPlade - 1), v) Then temp = Cells(I + (NyPlade - 1), v) Cells(I + (NyPlade - 1), v) = Cells(Iv + (NyPlade - 1), v) Cells(Iv + (NyPlade - 1), v) = temp End If Tekst2: Next Iv Tekst1: Next I Next
'**************************** sortering slut **************
If Sideskift = 5 Then Sideskift = 0 NyPlade = NyPlade + 5 Else NyPlade = NyPlade + 4 End If R = 1 Next ny Application.ScreenUpdating = True End Sub
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
