ich brauche ein Makro, das mir in Spalte A1:A10 per Zufall die Zahlen 1-9 füllt. Die Zahlen dürfen nicht doppelt vergeben sein.
Ist sowas möglich. Wenn ja wie?
Vielen Dank für Hilfe
Besten Dank
Sebastian
Sub sbZufzahl()
Dim liZufzahl As Integer
Sheets(1).Range("A1:A10").Value = ""
Do Until fcIsEmpty = False
Randomize
liZufzahl = Int((10 * Rnd))
sbOnly liZufzahl
Loop
End Sub
Function fcIsEmpty() As Boolean
Dim liRow As Integer
For liRow = 1 To 10
If Sheets(1).Range("A" & liRow).Value = "" Then
fcIsEmpty = True
Exit For
End If
Next
End Function
Sub sbOnly(ByVal zufzahl As Integer)
Dim liRow As Integer, lboTreffer As Boolean, liNext As Integer
If Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row = 1 And Sheets(1).Range("A1").Value = "" _
Then
liNext = 1
Else
liNext = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
For liRow = 1 To 10
If Sheets(1).Range("A" & liRow).Value = zufzahl And _
Sheets(1).Range("A" & liRow).Value "" Then
lboTreffer = True
Exit For
End If
Next
If lboTreffer = False Then
Sheets(1).Range("A" & liNext).Value = zufzahl
End If
End Sub
Sub ZufallszahlenSpalteA10()
Dim lngZahl(1 To 10), lngZ As Long
For lngZ = LBound(lngZahl) To UBound(lngZahl)
Randomize Timer
lngZahl(lngZ) = Rnd()
Next
For lngZ = LBound(lngZahl) To UBound(lngZahl)
Cells(lngZ, 1) = Application.Match(Application.Small(lngZahl, lngZ), lngZahl, 0)
Next
End Sub
Gruß, NoNet
Option Explicit
Sub RandomUniqueNumbers()
Dim i&, r&, lngRes&()
Dim hsh As Object, vntKeys
Const CNT As Long = 10
Columns(1).Clear
ReDim lngRes(CNT - 1)
Set hsh = CreateObject("Scripting.Dictionary")
For i = 0 To CNT - 1
hsh(i) = 0
Next
Randomize
For i = 0 To CNT - 1
r = Int(hsh.Count * Rnd)
vntKeys = hsh.Keys
lngRes(i) = vntKeys(r)
hsh.Remove vntKeys(r)
Next
Cells(1, 1).Resize(CNT) = Application.Transpose(lngRes)
End Sub
GrußWith Range("A1:B10")
.Columns(1).FormulaLocal="=Zeile()-1"
.Columns(2).FormulaLocal="=Zufallszahl()"
.formula = .value
.Sort Key1:=.Cells(1,2), order1:=xlascending, Header:=xlno
.Columns(2).ClearContents
End with