frage an chris wegen script

Sub Mischen() Dim i As Byte, ii As Byte On Error GoTo ErrorHandler: Calculate Application.Calculation = xlCalculationManual For i = 1 To 3 For ii = 1 To 5 If Application.WorksheetFunction.Rank(Cells(ii, 5), Range("E1:E5")) = i Then Cells(i, 2) = Cells(ii, 1) Exit For End If Next ii Next i Range("C1") = Range("C1") + 1 Application.Calculation = xlCalculationAutomatic ThisWorkbook.Save Exit Sub ErrorHandler: MsgBox ("Fehler: Vermutlich sind nicht genügend Teilnehmer (min. 3) eingetragen.") Application.Calculation = xlCalculationAutomatic End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Markus

Habe nochmals umgeschrieben, jetzt kannst du auf die Hilfsspalte verzichten.

Gruss
Chris

Option Explicit


Sub Mischen()
Dim Anzahl As Byte, iCounter As Byte, i As Integer
Dim Zwi1, Zwi2
' Anzahl Namen ermitteln
Anzahl = 5 - Application.WorksheetFunction.CountBlank(Range("B3:B7"))
If Anzahl < 3 Then
MsgBox "Es braucht mindestens 3 Teilnehmer."
Exit Sub
End If
' Namen in Array einlesen
ReDim MyArray(0 To 1, 0 To Anzahl - 1) As Variant
For i = 3 To 7
If Cells(i, 2) <> "" Then
MyArray(0, iCounter) = Cells(i, 2)
MyArray(1, iCounter) = Rnd
iCounter = iCounter + 1
End If
Next i
' Array sortieren
For i = Anzahl To 2 Step -1
If MyArray(1, i - 1) < MyArray(1, i - 2) Then
Zwi1 = MyArray(0, i - 1)
Zwi2 = MyArray(1, 1 - 1)
MyArray(0, i - 1) = MyArray(0, i - 2)
MyArray(1, i - 1) = MyArray(1, i - 2)
MyArray(0, i - 2) = Zwi1
MyArray(1, i - 2) = Zwi2
End If
Next i
' Ergebnis Eintragen
For i = 1 To 3
Cells(i + 2, 4) = MyArray(0, i - 1)
Next i
' Zähler
Range("A1") = Range("A1") + 1
' Speichern
ThisWorkbook.Save
End Sub

Sub Mischen() Dim Anzahl As Byte, i As Byte Dim Zufall As Byte, ii As Integer ' Anzahl Namen ermitteln Anzahl = 5 - Application.WorksheetFunction.CountBlank(Range("B3:B7")) If Anzahl < 3 Then MsgBox "Es braucht mindestens 3 Teilnehmer." Exit Sub End If ' Zufallszahlen in Array einlesen ReDim MyArray(Anzahl - 1) As Variant MyArray(0) = Int((Anzahl * Rnd) + 1) For i = 1 To Anzahl - 1 Start: Zufall = Int((Anzahl * Rnd) + 1) For ii = 0 To Anzahl - 1 If MyArray(ii) = Zufall Then GoTo Start Next ii MyArray(i) = Zufall Next i ' Ergebnis Namen in Tabelle eintragen For i = 1 To 3 For ii = 0 To Anzahl - 1 If MyArray(ii) = i Then Cells(i + 2, 4) = Cells(ii + 3, 2) Exit For End If Next ii Next i ' Zähler Range("A1") = Range("A1") + 1 ' Speichern ThisWorkbook.Save End Sub

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread