I stedet for, at pladerne blev vist under hinanden, har jeg brug for, at få dem lagt i en database.
Lad os sige, at værdierne fra de 3*9 felter, som en banko-plade fylder i stedet blev lagt i et databaseark i kolonnerne 1-28, hvor kolonne 1(A) viser hvilket nummer pladen har i rækken. Det skal altså stadig være muligt at vælge, hvor mange plader man ønsker genereret.
Al kode til formatering af rækker, kolonner, tekst, farver osv. kan således undlades.
Kolonne 2 til 10 indeholder række 1 fra pladen, kolonne 11 til 19 indeholder række 2 fra pladen og kolonne 20 til 28 indeholder den sidste række fra pladen.
Måske er det muligt, at gemme i nogle variable, som man så via en løkke lægger ind i databasen.
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 = "BANKO" ' 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
Public Sub BingoPladerTilBase() 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 Rcount(2) As Integer, Kol(8) As Integer Dim Plade(2, 8) As Variant, Base() As Variant Randomize BlankFeltTekst = "BANKO" ' ret blank felt tekst her Q = InputBox("indtast antal plader", "Antal plader", 1) ' antal plader, 5 på hvert A4 ark ReDim Base(Q, 27) '**************************************** Overskrifter ******************** I = 0 Base(0, 0) = "PladeNr." For R = 1 To 3 For K = 1 To 9 I = I + 1 Base(0, I) = "R" & R & "K" & K ' indsætter overskrifter Next Next '**************************************** Overskrifter slut ********************
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 For ny = 1 To Q
'****************************** 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
For I = 0 To 2 ' antal rækker
Start1: U = Int(Rnd * 3) + 1 'tilfældig placering på række UU(I) = U For Y = 0 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 Plade(I, R) = BlankFeltTekst ' bart felt GoTo BarFelt End If
For Y = 0 To I - 1 If C(Y) = X Then GoTo Start2 Next Y C(Y) = X Plade(I, R) = X
BarFelt: Next I R = R + 1 Next T '**************************** sortering 5 i hver række ************** TjekIgen:
For I = 0 To 2 Rcount(I) = 0 For j = 0 To 8 If IsNumeric(Plade(I, j)) 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 = 0 To 8 If IsNumeric(Plade(Fra, Iv)) Then ' rækken med mere end 5 If Plade(til, Iv) = BlankFeltTekst Then 'rækken med mindre end 5 og skal være blank Plade(til, Iv) = Plade(Fra, Iv) ' flytter række Plade(Fra, Iv) = BlankFeltTekst ' skriver blank tekst GoTo TjekIgen End If End If Next GoTo TjekIgen '**************************** sortering lodret stigende ************** AltOk: For v = 0 To 8 For I = 0 To 2 If Plade(I, v) = BlankFeltTekst Then GoTo Tekst1
For Iv = 0 To 1 If Plade(Iv, v) = BlankFeltTekst Then GoTo Tekst2 If Plade(I, v) < Plade(Iv, v) Then temp = Plade(I, v) Plade(I, v) = Plade(Iv, v) Plade(Iv, v) = temp End If Tekst2: Next Iv Tekst1: Next I Next
'**************************** sortering slut ************** Base(ny, 0) = ny For I = 1 To 9
Base(ny, I) = Plade(1, I - 1) Next For I = 10 To 18 Base(ny, I) = Plade(2, I - 10) Next For I = 19 To 27 Base(ny, I) = Plade(1, I - 19) Next
R = 0 Next ny Range(Cells(1, 1), Cells(Q + 1, 28)) = Base End Sub
Base(ny, 0) = ny For I = 1 To 9 Base(ny, I) = Plade(0, I - 1) Next For I = 10 To 18 Base(ny, I) = Plade(1, I - 10) Next For I = 19 To 27 Base(ny, I) = Plade(2, I - 19)
Public Sub BingoPladerTilBase() 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 Rcount(2) As Integer, Kol(8) As Integer Dim Plade(2, 8) As Variant, Base() As Variant Randomize BlankFeltTekst = "<>" ' ret blank felt tekst her Q = InputBox("indtast antal plader", "Antal plader", 1) ' antal plader, 5 på hvert A4 ark ReDim Base(Q, 27) '**************************************** Overskrifter ******************** I = 0 Base(0, 0) = "PladeNr." For R = 1 To 3 For K = 1 To 9 I = I + 1 Base(0, I) = "R" & R & "K" & K ' indsætter overskrifter Next Next '**************************************** Overskrifter slut ********************
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 For ny = 1 To Q
'****************************** 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
For I = 0 To 2 ' antal rækker
Start1: U = Int(Rnd * 3) + 1 'tilfældig placering på række UU(I) = U For Y = 0 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 Plade(I, R) = BlankFeltTekst ' bart felt GoTo BarFelt End If
For Y = 0 To I - 1 If C(Y) = X Then GoTo Start2 Next Y C(Y) = X Plade(I, R) = X
BarFelt: Next I R = R + 1 Next T '**************************** sortering 5 i hver række ************** TjekIgen:
For I = 0 To 2 Rcount(I) = 0 For j = 0 To 8 If IsNumeric(Plade(I, j)) 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 = 0 To 8 If IsNumeric(Plade(Fra, Iv)) Then ' rækken med mere end 5 If Plade(til, Iv) = BlankFeltTekst Then 'rækken med mindre end 5 og skal være blank Plade(til, Iv) = Plade(Fra, Iv) ' flytter række Plade(Fra, Iv) = BlankFeltTekst ' skriver blank tekst GoTo TjekIgen End If End If Next GoTo TjekIgen '**************************** sortering lodret stigende ************** AltOk: For v = 0 To 8 For I = 0 To 2 If Plade(I, v) = BlankFeltTekst Then GoTo Tekst1
For Iv = 0 To 1 If Plade(Iv, v) = BlankFeltTekst Then GoTo Tekst2 If Plade(I, v) < Plade(Iv, v) Then temp = Plade(I, v) Plade(I, v) = Plade(Iv, v) Plade(Iv, v) = temp End If Tekst2: Next Iv Tekst1: Next I Next
'**************************** sortering slut ************** Base(ny, 0) = ny For I = 1 To 9 Base(ny, I) = Plade(0, I - 1) Next For I = 10 To 18 Base(ny, I) = Plade(1, I - 10) Next For I = 19 To 27 Base(ny, I) = Plade(2, I - 19) Next
R = 0 Next ny Range(Cells(1, 1), Cells(Q + 1, 28)) = Base End Sub
Der er nu sat en tæller på der skriver hvor mange gange, et tal er brugt til pladerne.
Den skriver det i AD 0g AE kolonnen
Public Sub BingoPladerTilBase() 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 Rcount(2) As Integer, Kol(8) As Integer Dim Plade(2, 8) As Variant, Base() As Variant, AntalAfTal(90) Randomize BlankFeltTekst = "<>" ' ret blank felt tekst her Q = InputBox("indtast antal plader", "Antal plader", 1) ' antal plader, 5 på hvert A4 ark ReDim Base(Q, 27) '**************************************** Overskrifter ******************** I = 0 Base(0, 0) = "PladeNr." For R = 1 To 3 For K = 1 To 9 I = I + 1 Base(0, I) = "R" & R & "K" & K ' indsætter overskrifter Next Next '**************************************** Overskrifter slut ********************
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 For ny = 1 To Q
'****************************** 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
For I = 0 To 2 ' antal rækker
Start1: U = Int(Rnd * 3) + 1 'tilfældig placering på række UU(I) = U For Y = 0 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 Plade(I, R) = BlankFeltTekst ' bart felt GoTo BarFelt End If
For Y = 0 To I - 1 If C(Y) = X Then GoTo Start2 Next Y C(Y) = X Plade(I, R) = X AntalAfTal(X) = AntalAfTal(X) + 1 ' tæller hvor mange genge tallet er valgt BarFelt: Next I R = R + 1 Next T '**************************** sortering 5 i hver række ************** TjekIgen:
For I = 0 To 2 Rcount(I) = 0 For j = 0 To 8 If IsNumeric(Plade(I, j)) 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 = 0 To 8 If IsNumeric(Plade(Fra, Iv)) Then ' rækken med mere end 5 If Plade(til, Iv) = BlankFeltTekst Then 'rækken med mindre end 5 og skal være blank Plade(til, Iv) = Plade(Fra, Iv) ' flytter række Plade(Fra, Iv) = BlankFeltTekst ' skriver blank tekst GoTo TjekIgen End If End If Next GoTo TjekIgen '**************************** sortering lodret stigende ************** AltOk: For v = 0 To 8 For I = 0 To 2 If Plade(I, v) = BlankFeltTekst Then GoTo Tekst1
For Iv = 0 To 1 If Plade(Iv, v) = BlankFeltTekst Then GoTo Tekst2 If Plade(I, v) < Plade(Iv, v) Then temp = Plade(I, v) Plade(I, v) = Plade(Iv, v) Plade(Iv, v) = temp End If Tekst2: Next Iv Tekst1: Next I Next
'**************************** sortering slut ************** Base(ny, 0) = ny For I = 1 To 9 Base(ny, I) = Plade(0, I - 1) Next For I = 10 To 18 Base(ny, I) = Plade(1, I - 10) Next For I = 19 To 27 Base(ny, I) = Plade(2, I - 19) Next
R = 0 Next ny Range(Cells(1, 1), Cells(Q + 1, 28)) = Base ' ********skriver i kolonne AD og AE hvor mange gange hvert tal er kommet ud på plade Range("AD1") = "nr." Range("AE1") = "Antal" For I = 1 To 90 Range("AD" & I + 1) = I Range("AE" & I + 1) = AntalAfTal(I) Next End Sub
Here goes: (kabbaks formatering er "lånt") PrintPlade rutinen kan nemt laves om så den skriver til et databaseark. Kommentare er velkomne.
Option Base 1 Dim PladeTal As Byte Dim Plade() As Byte Sub BingoPlader() Dim i As Byte Cells.Delete For i = 0 To InputBox("Hvor mange plader", "Bingo plader") Call GenPlade(i * 7 + 1, 1) Next i End Sub
Sub GenPlade(ByVal Xoff, Yoff As Integer) Dim i, j As Byte ReDim Plade(9, 4) As Byte Randomize Call FormatPlade(Xoff, Yoff) For j = 1 To 3 i = 1 While i <= 5 PladeTal = CByte(Rnd() * 90) + 1 If PullNum(j) Then i = i + 1 Wend Next j Call SortPlade Call PrintPlade(Xoff, Yoff) End Sub
Columns("B:J").ColumnWidth = 8 Range("A:A,K:K").ColumnWidth = 2 Rows("1:1").RowHeight = 12 Range("A1:K5").Offset(Xoff - 1, Yoff - 1).Interior.ColorIndex = KantFarve With Range("A1:I3").Offset(Xoff, Yoff) .Interior.ColorIndex = BagFarve .ClearContents .Font.Size = StorTekst .RowHeight = 40 .Borders.LineStyle = xlContinuous .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End Sub
Function PullNum(ByVal r As Byte) As Boolean Select Case PladeTal Case 1 To 9: If InsertNum(1, PladeTal, r) Then PullNum = True Case 10 To 19: If InsertNum(2, PladeTal, r) Then PullNum = True Case 20 To 29: If InsertNum(3, PladeTal, r) Then PullNum = True Case 30 To 39: If InsertNum(4, PladeTal, r) Then PullNum = True Case 40 To 49: If InsertNum(5, PladeTal, r) Then PullNum = True Case 50 To 59: If InsertNum(6, PladeTal, r) Then PullNum = True Case 60 To 69: If InsertNum(7, PladeTal, r) Then PullNum = True Case 70 To 79: If InsertNum(8, PladeTal, r) Then PullNum = True Case 80 To 90: If InsertNum(9, PladeTal, r) Then PullNum = True Case Else: PullNum = False End Select End Function
Function InsertNum(ByVal Kol, tal, r As Byte) As Boolean Dim n As Byte Dim z As Boolean z = False If r = 3 Then For n = 1 To 9 If CInt(Plade(n, 1)) + Plade(n, 2) + Plade(n, 3) = 0 Then If n <> Kol Then insernum = False Exit Function Else Exit For End If End If Next n End If If Plade(Kol, r) <> 0 Or Plade(Kol, 1) = tal Or Plade(Kol, 2) = tal Or Plade(Kol, 3) = tal Then InsertNum = False Else Plade(Kol, r) = tal InsertNum = True End If End Function
Sub SortPlade() Dim n, m, c, t As Byte For n = 1 To 9 For m = 1 To 2 For c = m To 3 If Plade(n, m) > Plade(n, c) And Plade(n, m) > 0 And Plade(n, c) > 0 Then t = Plade(n, m) Plade(n, m) = Plade(n, c) Plade(n, c) = t End If Next c Next m Next n End Sub
Sub PrintPlade(ByVal x, y As Integer) Dim i, j As Byte For i = 1 To 9 For j = 1 To 3 If Plade(i, j) <> 0 Then Cells(x + j, y + i) = Plade(i, j) Next j Next i End Sub
Jeg legede lige lidt med statistik-delen. Jeg er bange for, at numrene alligevel ikke er helt tilfældige. De små numre 1-10 forekommer meget oftere end de store numre 80-90.
Softcareconsult> Din kode ser spændende ud. Selv om der ikke er nok programmør i mig til at følge med hele vejen, så virker den tilsyneladende upåklagelig. (Måske lige bortset fra, at den ikke helt laver det rigtige antal poster.)
Har du mulighed for at lave en databaseversion og evt. en tilsvarende statistikdel som kabbaks? Så belønner jeg gerne med nogle point. Kolonne A må gerne indeholde pladenummer og B og C reserveret til andre formål.
Jeg vil da også gerne være med :-) Denne her har ikke tendensen , så vidt jeg kan se.
Option Base 1 Option Explicit
Sub main() Dim lAntal As Long, s As Long lAntal = Application.InputBox("Hvor mange plader ?") For s = 2 To lAntal + 1
Range("D" & s & ":AD" & s) = Make27Numbers
Next End Sub Function Make27Numbers() Dim TmpArray(27) Dim k As Long, z As Long, i As Long, j As Long, x As Long, y As Long k = 0 z = 0 For i = 0 To 80 Step 10 j = 0 While j < 3 If i = 0 Then y = 1 Else y = 0 If i = 80 Then z = 1 Else z = 0 x = rndbetween(i + y, i + 9 + z) If Not IsInArray(TmpArray, x) Then k = k + 1 TmpArray(k) = x j = j + 1 End If Wend Next BubbleSort TmpArray() PickOut15 TmpArray Make27Numbers = TmpArray End Function Function IsInArray(MyArray, TestValue) IsInArray = IIf(UBound(Filter(MyArray, TestValue)) < 0, False, True) End Function Function rndbetween(low, high) Dim tmp As Long tmp = high - low + 1 rndbetween = Int(Rnd() * tmp) + low End Function Sub PickOut15(list()) Dim skema(3, 9) Dim i As Long, j As Long, lRow As Long, lCol As Long, x As Long Dim tal5 As Long, tal3 As Long Randomize Timer For i = 1 To 3 For j = 1 To 9 skema(i, j) = 1 Next Next Do Until x = 12 lRow = Int(Rnd() * 3) + 1 lCol = Int(Rnd() * 9) + 1
If skema(lRow, lCol) = 0 Then GoTo hop skema(lRow, lCol) = 0 tal5 = 0 tal3 = 0 For i = 1 To 9 tal5 = tal5 + skema(lRow, i) Next For i = 1 To 3 tal3 = tal3 + skema(i, lCol) Next If (tal5 >= 5 And tal3 >= 1) Then x = x + 1 Else skema(lRow, lCol) = 1 hop: Loop x = 0 For i = 1 To 9 For j = 1 To 3 x = x + 1 If skema(j, i) = 0 Then list(x) = "TOM" Next Next End Sub Sub BubbleSort(list()) Dim First As Integer, Last As Long Dim i As Long, j As Long Dim Temp As Long
First = LBound(list) Last = UBound(list) For i = First To Last - 1 For j = i + 1 To Last If list(i) > list(j) Then Temp = list(j) list(j) = list(i) list(i) = Temp End If Next j Next i End Sub
den var nok ikke så nem at gennemskue. Jeg prøver lige igen
Option Base 1 Option Explicit
Sub main() Dim lAntal As Long, s As Long lAntal = Application.InputBox("Hvor mange plader ?") For s = 2 To lAntal + 1
Range("D" & s & ":AD" & s) = Make27Numbers
Next End Sub
Function Make27Numbers() Dim TmpArray(27) Dim k As Long, z As Long, i As Long, j As Long, x As Long, y As Long k = 0 z = 0 For i = 0 To 80 Step 10 j = 0 While j < 3 If i = 0 Then y = 1 Else y = 0 If i = 80 Then z = 1 Else z = 0 x = rndbetween(i + y, i + 9 + z) If Not IsInArray(TmpArray, x) Then k = k + 1 TmpArray(k) = x j = j + 1 End If Wend Next BubbleSort TmpArray() PickOut15 TmpArray Make27Numbers = TmpArray End Function
Function IsInArray(MyArray, TestValue) IsInArray = IIf(UBound(Filter(MyArray, TestValue)) < 0, False, True) End Function
Function rndbetween(low, high) Dim tmp As Long tmp = high - low + 1 rndbetween = Int(Rnd() * tmp) + low End Function
Sub PickOut15(list()) Dim skema(3, 9) Dim i As Long, j As Long, lRow As Long, lCol As Long, x As Long Dim tal5 As Long, tal3 As Long Randomize Timer For i = 1 To 3 For j = 1 To 9 skema(i, j) = 1 Next Next Do Until x = 12 lRow = Int(Rnd() * 3) + 1 lCol = Int(Rnd() * 9) + 1
If skema(lRow, lCol) = 0 Then GoTo hop skema(lRow, lCol) = 0 tal5 = 0 tal3 = 0 For i = 1 To 9 tal5 = tal5 + skema(lRow, i) Next For i = 1 To 3 tal3 = tal3 + skema(i, lCol) Next If (tal5 >= 5 And tal3 >= 1) Then x = x + 1 Else skema(lRow, lCol) = 1 hop: Loop x = 0 For i = 1 To 9 For j = 1 To 3 x = x + 1 If skema(j, i) = 0 Then list(x) = "TOM" Next Next End Sub
Sub BubbleSort(list()) Dim First As Integer, Last As Long Dim i As Long, j As Long Dim Temp As Long
First = LBound(list) Last = UBound(list) For i = First To Last - 1 For j = i + 1 To Last If list(i) > list(j) Then Temp = list(j) list(j) = list(i) list(i) = Temp End If Next j Next i End Sub
Men er forklaringen ikke at der fra 1-9 er 9 tal, men fra 80-90 er 11 tal. Det vil jo gøre at 1-9 bliver valgt flere gange end 80-90, da der ikke så mange at vælge imellem.
Det er selvfølgelig lidt af forklaringen, men der er stadig "noget om snakken". På oversigten over alle 90 tal, var mønstret også tydeligt. Såvidt jeg husker var det tallene "1" og "6" som forekom oftest.
Jeg testede lige min egen med 10000 rækker. Jeg synes at dette ser rigtigt nok ud: 0-9 16582 10-19 16702 20-29 16767 30-39 16586 40-49 16650 50-59 16626 60-69 16740 70-79 16681 80-90 16666
og talforekomsterne svingede mellem 1904 og 1402 (enkelttal) i enkelttallene bør 1-9 være højere end 10-79 og 80-90 lavere. og det ser også ud til at holde stik
Jeg har lige skrevet til Bak, men I tilfælde af Bak ikke ser min besked, skriver jeg lige her også. Håber I kan hjælpe.
Jeg har fået til opgave at lave mellem en masse bankoplader +50.000
Jeg vil gerne selv flette dem i InDesign ud fra en database (txt fil der er gemt ned fra Excel). Jeg tænker at det er lettest at flette ud fra en database med +50.000 rækker, der hvad har 27 kolonner - en kolonne for hvert felt, som jeg jeg så parer med feltet jeg har lavet på pladen i InDesign.
Kan det alternativt lade sig gøre at lave PDF'er fra Excel.
Slutproduktet skal være 4 bankoplader på et ark der er 147x297 mm, men det håber jeg at kunne fixe efterfølgende. Tænker det er lettest at lave en plade ad gagen.
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.
