Prøv denne, med rammer og afkrydsnings felt til højre, 20 sider.
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
Application.ScreenUpdating = False
On Error GoTo ErrorHandle
'Tabelområdet defineres f.eks. som området A1 til J1000
'på det første faneblad.
Set rTabel = Worksheets(1).Range("A1", "J1000")
'Definerer intervallet (her 0 til 10000).
lMin = 0
lMax = 10000
'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
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("D:D").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("F:F").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("H:H").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("J:J").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("L:L").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("N:N").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("P:P").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("R:R").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("T:T").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A:A,C:C,E:E,G:G,I:I,K:K,M:M,O:O,Q:Q,S:S").Select
Selection.ColumnWidth = 4.5
Range("T:T,R:R,P:P,N:N,L:L,J:J,H:H,F:F,D:D,B:B").Select
Selection.ColumnWidth = 2
Range("A:A,C:C,E:E,G:G,I:I,K:K,M:M,O:O,Q:Q,S:S").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.NumberFormat = "####0000"
Range("A1:T1000").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("A1").Select
Application.ScreenUpdating = True
BeforeExit:
Set rCell = Nothing
Set rTabel = Nothing
Set colValues = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandle:
Application.ScreenUpdating = True
MsgBox Err.Description & " Fejl i proceduren LavUnikTabel."
Resume BeforeExit
End Sub
Ny bruger
Nybegynder
Opret
Preview
