Doppelte ausschließen..........

Sub LottoZahlenErstellen() If Sheets("Zettel").Range("E6").Value > 12 Then MsgBox " Sie müssen erst den Lottozettel zurücksetzen!" Exit Sub End If Sheets("Zettel").Range("C1:O1").ClearContents With Application .Calculation = xlManual .MaxChange = 0.001 End With Randomize With Sheets("Zettel") .Range("C1").Value = Int(49 * Rnd) + 1 .Range("E1").Value = Int(49 * Rnd) + 1 .Range("G1").Value = Int(49 * Rnd) + 1 .Range("I1").Value = Int(49 * Rnd) + 1 .Range("L1").Value = Int(49 * Rnd) + 1 .Range("N1").Value = Int(49 * Rnd) + 1 End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Sonnenpeter,
so vielleicht:

Public Sub KeineDoppelten()
Dim aZahlen(1 To 6)  As Integer
Dim iZahl            As Integer
Dim iIndx            As Integer
Dim iEinfg           As Integer
Dim aGefu            As Boolean
   iEinfg = 1

   Do
      Randomize
      iZahl = Int(49 * Rnd) + 1
      aGefu = False
      For iIndx = 1 To UBound(aZahlen)
         If aZahlen(iIndx) = iZahl Then
            aGefu = True
            Exit For
         End If
      Next iIndx
      If aGefu = False Then
         aZahlen(iEinfg) = iZahl
         iEinfg = iEinfg + 1
      End If
   Loop Until iEinfg > 6

   MsgBox "die Zahlen: " & aZahlen(1) & ", " & aZahlen(2) & ", " & _
          aZahlen(3) & ", " & aZahlen(4) & ", " & aZahlen(5) & _
          ", " & aZahlen(6)

Viele Grüße Peter
Eine kurze Nachricht, ob es läuft, wäre nett - danke.

Sub LottoZahlenErstellen() Dim anz As Byte, n As Byte, Wort As String, pos As Byte anz = 49 If Sheets("Zettel").Range("E6").Value > 12 Then MsgBox " Sie müssen erst den Lottozettel zurücksetzen!" Exit Sub End If Sheets("Zettel").Range("C1:O1").ClearContents With Application .Calculation = xlManual .MaxChange = 0.001 End With Randomize For n = 1 To anz Wort = Wort & Right("0" & CStr(n), 2) Next n With Sheets("Zettel") For n = 3 To 11 Step 2 pos = 2 * (Int(anz * Rnd)) + 1 anz = anz - 1 .Cells(1, n) = CInt(Mid(Wort, pos, 2)) Wort = Left(Wort, pos - 1) & Mid(Wort, pos + 2) Next n End With End Sub

Hallo Peter!
Eine Möglichkeit!

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Function RandomNumbers(StartNumber As Long, EndNumber As Long, Count As Integer, Field As Variant)
Dim intIndex As Integer, intCount As Integer
Dim varTemp() As Variant, varT() As Variant

intCount = EndNumber - StartNumber
Redim varTemp(intCount)
If Count > intCount Then Count = intCount
Redim varT(Count)

For intIndex = 0 To intCount
  varTemp(intIndex) = StartNumber + intIndex
Next

Randomize

For intCount = 0 To Count
  intIndex = Int((Rnd * UBound(varTemp)))
  varT(intCount) = varTemp(intIndex)
  varTemp(intIndex) = varTemp(UBound(varTemp))
  If UBound(varTemp) = 0 Then Exit For
  Redim Preserve varTemp(UBound(varTemp) - 1)
Next

Field = varT

End Function

Sub LottoZahlenErstellen()
Dim varNumbers As Variant

If Sheets("Zettel").Range("E6").Value > 12 Then
  MsgBox " Sie müssen erst den Lottozettel zurücksetzen!"
  Exit Sub
End If

Sheets("Zettel").Range("C1:O1").ClearContents

With Application
  .Calculation = xlManual
  .MaxChange = 0.001
End With

RandomNumbers 1, 49, 6, varNumbers

With Sheets("Zettel")
  .Range("C1").Value = varNumbers(0)
  .Range("E1").Value = varNumbers(1)
  .Range("G1").Value = varNumbers(2)
  .Range("I1").Value = varNumbers(3)
  .Range("L1").Value = varNumbers(4)
  .Range("N1").Value = varNumbers(5)
End With

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread