Hjælp! Fejl i kode, kontrolfunktion virker ikke!
Jeg skal have lavet en god slat bankoplader via en Excel database med 27 rækker - en række for hver plade.En bankoplade har 27 felter fordelt på 3 rækker.
Første kolonne cifre fra 1-9, anden række cifre fra 10-19 osv.
Hver række skal indeholde 5 cifre, altså 15 cifre på en hel plade
De resterede 12 felter er tomme på tilfældige pladser.
Jeg har fundet nedenstående VBA kode, men en der har testkørt den, melder tilbage at den har lavet to rækker, der indeholder samme 15 cifre, hvilket er det jeg vil undgå. Koden skal altså, inden den skriver en ny række, kontrollere at der ikke allerede er en række med samme 15 cifre i de 27 celler. Vær opmærksom på at cifrene kan stå i varierende celler i rækken, da de 12 tomme celler placeret tilfældigt.
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