AW: Zeilen nach Zufallsprinzip löschen
29.04.2008 22:04:00
Peter
Hallo Jan-Gerrit,
nach einem Code von Sepp Ehrensberger etwas modifiziert - es gibt keine doppelten Zahel, also echte 444
Option Explicit
Sub ZufallsZahlen()
Dim dblZahlen() As Long, dblGezogen() As Variant
Dim intCount As Integer, intIndex As Integer, intZufall As Integer
Dim intStart As Integer, intEnde As Integer, intAnzahl As Integer
intStart = 1 'Erste Zahl
intEnde = 5444 'Letzte Zahl
intAnzahl = 444 'Anzahl Zufallszahlen
ReDim dblZahlen(intEnde - intStart)
ReDim dblGezogen(intAnzahl - 1)
'Array füllen
For intCount = intStart To intEnde
dblZahlen(intIndex) = intCount
intIndex = intIndex + 1
Next
intIndex = 0
Randomize Timer
'Zufallszahlen ziehen
For intCount = 0 To intAnzahl - 1
intZufall = Int(Rnd() * UBound(dblZahlen))
dblGezogen(intIndex) = dblZahlen(intZufall)
dblZahlen(intZufall) = dblZahlen(UBound(dblZahlen))
If UBound(dblZahlen) = 0 Then Exit For
ReDim Preserve dblZahlen(UBound(dblZahlen) - 1)
intIndex = intIndex + 1
Next
'Zufallszahlen sortieren
QuickSort dblGezogen
'In Bereich ausgeben (ab "A1")
'Range(Cells(1, 2), Cells(intAnzahl, 2)) = Application.Transpose(dblGezogen)
'die Zufallszeilen löschen
For intIndex = 443 To 0 Step -1
Rows(dblGezogen(intIndex)).Delete Shift:=xlUp
Next intIndex
End Sub
' Quicksort
'
Sub QuickSort(data() As Variant, Optional UG, Optional OG)
Dim P1&, P2&, T1 As Variant, T2 As Variant
UG = IIf(IsMissing(UG), LBound(data), UG)
OG = IIf(IsMissing(OG), UBound(data), OG)
P1 = UG
P2 = OG
T1 = data((P1 + P2) / 2)
Do
Do While (data(P1) T1)
P2 = P2 - 1
Loop
If P1 P2)
If UG
Gruß Peter