Anzeige
Archiv - Navigation
1940to1944
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

25 Zufallszahlen, mit immer gleicher Endsumme

25 Zufallszahlen, mit immer gleicher Endsumme
10.08.2023 16:31:03
Klaus F.
Hallo, etwas für VBA Cracks:

ich habe 25 Spalten (A - Y) mit 20 Zeilen und möchte in jeder Zeile Zufallszahlen von 1 bis 25 haben.
Das Problem: Die Addition einer Zeile soll dabei immer genau 400 ergeben.

Zahlen dürfen pro Zeile natürlich mehrfach auftreten.

Gesucht wird eine VBA-Lösung, gerne auch als Ansatz für meine grauen Zellen
(habe allerdings schon lange kein VBA mehr gemacht).
Super wäre, wenn man die beiden Parameter Zufallszahlen und Endergebnis variabel gestalten könnte, ist aber kein Muss.

Danke für jede Hilfe im voraus
Klaus

14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: 25 Zufallszahlen, mit immer gleicher Endsumme
10.08.2023 17:08:18
daniel
HI
mal so als Ansatz:

pro Zeile dieser Ablauf in einer DO-Schleife
1. in die Zellen A-X die Formel =Zufallsbereich(1;25), Formel durch Wert ersezten
2. in die Zelle Y die Formel: =400 - Summe(A:X)
3. prüfen, ob der Wert in Y im erlaubten Bereich liegt (1-25), wenn ja, Schleife verlassen, wenn nicht, dann Schleife wiederholen.

Gruß Daniel
Ergebnis Datei
13.08.2023 21:06:10
KlausF
Moin,

falls jemand mal ein ähnliches Problem hat habe ich hier meine Datei hochgeladen:
https://www.herber.de/bbs/user/162317.xlsm

Der Code ist sicher nicht 1a (habe schon seit Jahren nichts mehr gemacht) aber er funktioniert und ist auch schnell.

Zusätzlich habe ich eine farbige Ziffernanzeige eingebaut (Grün, Orange, Rot), die im Vorwege anzeigt, wenn die Werte ungünstig gesetzt sind und das Makro entweder sehr lange laufen würde oder praktisch kein sinnvolles Ergebnis hervor bringt.

Danke an alle für den Input.

Gruß
Klaus
Anzeige
AW: 25 Zufallszahlen, mit immer gleicher Endsumme
11.08.2023 10:36:44
KlausF
Hallo Ulf,

Danke für Deine Lösung.
Ich habe mittlerweile selber eine relativ schnelle VBA-Lösung dank Daniels Hinweis erarbeitet.

Trotzdem Danke nochmal ...

Gruß
Klaus
25 Zufallszahlen, mit immer gleicher Endsumme
11.08.2023 20:08:51
Ulf
Hi Klaus,
ja die Performance ließ zu wünschen übrig, Formel wahrscheinlich x10 schneller.
Da das aber ein allgemeingültiges Problem löst, kommt es in angepasster Form ins Excel-Archiv.
https://www.herber.de/bbs/user/162294.xlsm
Grüsse
Ulf
25 Zufallszahlen, mit immer gleicher Endsumme
11.08.2023 20:39:36
daniel
10 mal schneller kommt hin.
23 sekunden gegen 2 sekunden bei mir.

wobei das der Code ist, der 2 sekunden braucht:
Sub starte2()

Dim yZahlen As Long
Dim xZahlen As Long
Dim von As Long
Dim bis As Long
Dim z As Long
Dim Ziel As Long
Dim x As Long

xZahlen = Range("xzahlen")
yZahlen = Range("yZahlen")
von = Range("MinZahl")
bis = Range("MaxZahl")
Ziel = Range("Sollsumme")

With Sheets("Ausgabe")
.Cells.Clear
For z = 1 To yZahlen
Do
With .Cells(z, 2).Resize(1, xZahlen - 1)
.FormulaR1C1 = "=randbetween(" & von & "," & bis & ")"
.Formula = .Value
x = Ziel - WorksheetFunction.Sum(.Cells)
End With
If x >= von And x = bis Then
.Cells(z, 1) = x
Exit Do
End If
Loop
Next
End With

End Sub


und das hier die 23.
und wenn man noch die Zeit berücktsichtigt, bis die man braucht, um die Codes zu verstehen....
Option Explicit


Private mColZahlen() As Long
Private mMin As Long
Private mMax As Long
Private mAnzahl As Long
Private mWunschSumme As Long

Private mSumme As Long

Private Sub Class_Initialize()
Application.EnableCancelKey = xlErrorHandler
mMin = 1
mMax = 25
mAnzahl = 20
ReDim mColZahlen(mAnzahl - 1)
End Sub

Public Sub Class_Initialize2(ByVal Anzahl, ByVal WunschSumme, Optional lngMin As Long = 1, Optional lngMax As Long = 25)
Application.EnableCancelKey = xlErrorHandler
mWunschSumme = WunschSumme
mAnzahl = Anzahl
mMin = lngMin
mMax = lngMax
ReDim mColZahlen(mAnzahl - 1)
End Sub

Public Property Get Anzahl() As Long
Anzahl = mAnzahl
End Property

Public Property Let Anzahl(ByVal lngNew As Long)
mAnzahl = lngNew
End Property

Public Property Get Summe() As Long
Summe = mSumme
End Property

Public Property Get Member(ByVal lngIndex As Long) As Long
Member = mColZahlen(lngIndex)
End Property

Public Function Berechnen() As Boolean
Dim bRet As Boolean
Application.EnableCancelKey = xlErrorHandler
bRet = Generate
Berechnen = bRet
End Function

Private Function Gesamt() As Long
Dim varZahl As Variant
Dim i As Long
Dim lngRet As Long
Application.EnableCancelKey = xlErrorHandler
For i = 0 To UBound(mColZahlen)
lngRet = lngRet + mColZahlen(i)
Next
Gesamt = lngRet
End Function

Private Function Generate() As Boolean
On Local Error GoTo GenerateERR
Dim bRet As Boolean
Dim lngIndex As Long
Application.EnableCancelKey = xlErrorHandler
For lngIndex = 0 To mAnzahl - 1
mColZahlen(lngIndex) = neueZahl
Next lngIndex
mSumme = Gesamt
Do Until mSumme = mWunschSumme
'lngIndex = CLng(((mAnzahl - 1) - 1) * Rnd() + 1)
lngIndex = grösste
mColZahlen(lngIndex) = neueZahl
DoEvents
mSumme = Gesamt
Application.StatusBar = mSumme
Loop
Application.StatusBar = ""
bRet = True
GenerateOUT:
Generate = bRet
Exit Function
GenerateERR:
bRet = False
Debug.Print Err.Number & vbCrLf & Err.Description
Resume GenerateOUT
'Resume Next
End Function

Private Function neueZahl() As Long
Application.EnableCancelKey = xlErrorHandler
Randomize
neueZahl = CLng((mMax - mMin + 1) * Rnd() + mMin)
End Function

'Stichprobe und bestes Nähern
Public Function grösste()
Dim arrProbe(2) As Long
Dim i As Long
Dim lngRet As Long
Dim lngIndex(2) As Long
Application.EnableCancelKey = xlErrorHandler
Randomize
lngIndex(0) = CLng(((mAnzahl - 1) - 1) * Rnd() + 1)
Randomize
lngIndex(1) = CLng(((mAnzahl - 1) - 1) * Rnd() + 1)
Randomize
lngIndex(2) = CLng(((mAnzahl - 1) - 1) * Rnd() + 1)
arrProbe(0) = mColZahlen(lngIndex(0))
arrProbe(1) = mColZahlen(lngIndex(1)) 'mColZahlen(CLng((mAnzahl - 1) / 2))
arrProbe(2) = mColZahlen(lngIndex(2))
For i = 2 To 0 Step -1
If mSumme > mWunschSumme Then
If arrProbe(i) > arrProbe(lngRet) Then
lngRet = i
End If
Else
If arrProbe(i) arrProbe(lngRet) Then
lngRet = i
End If
End If
Next
Select Case lngRet
Case 0
grösste = lngIndex(0) '0
Case 1
grösste = lngIndex(1) 'lngIndex 'CLng((mAnzahl - 1) / 2)
Case 2
grösste = lngIndex(2) 'mAnzahl - 1
End Select
End Function



Public Sub Starte()
On Local Error GoTo StarteERR
Dim x As New clZufall
Dim i As Long, j As Long
Dim lngAnzahl As Long
Dim lngZeilen As Long
Dim lngSollSumme As Long
Dim lngMin As Long
Dim lngMax As Long
Dim wksOut As Worksheet
Dim dblStart As Double
Dim dblEnde As Double
ThisWorkbook.Worksheets("Config").Range("A3").Value = ""
dblStart = DateSerial(Year(Now), Month(Now), Day(Now)) + TimeSerial(Hour(Time), Minute(Time), Second(Time))
If Not ThisWorkbook.Worksheets("Config").Range("A1").Value Then
MsgBox "Keine Lösung möglich !", vbCritical + vbOKOnly, "Fehler"
Exit Sub
End If
Application.EnableCancelKey = xlErrorHandler
lngAnzahl = ThisWorkbook.Names("XZahlen").RefersToRange.Value
lngZeilen = ThisWorkbook.Names("YZahlen").RefersToRange.Value
lngSollSumme = ThisWorkbook.Names("Sollsumme").RefersToRange.Value
lngMin = ThisWorkbook.Names("MinZahl").RefersToRange.Value
lngMax = ThisWorkbook.Names("MaxZahl").RefersToRange.Value
Set wksOut = ThisWorkbook.Worksheets("Ausgabe")
wksOut.UsedRange.Clear
For j = 1 To lngZeilen
Set x = New clZufall
x.Class_Initialize2 lngAnzahl, lngSollSumme, lngMin, lngMax
If x.Berechnen() Then
For i = 0 To x.Anzahl - 1
wksOut.Cells(j, i + 1) = x.Member(i)
Next
Else
Exit For
End If
Next j
dblEnde = DateSerial(Year(Now), Month(Now), Day(Now)) + TimeSerial(Hour(Time), Minute(Time), Second(Time))
ThisWorkbook.Worksheets("Config").Range("A3").Value = CVDate(dblEnde - dblStart)
StarteOUT:
Exit Sub
StarteERR:
Resume StarteOUT
End Sub


kann das mal einer erklären?
Anzeige
25 Zufallszahlen, mit immer gleicher Endsumme
11.08.2023 21:21:06
Ulf
Hi Daniel,
Ich messe für das Generieren von 20 Zeilen mit diesem Code: 2sec.
In der Datei sind 200 Zeilen vorgegeben.
Erklärt das ?
25 Zufallszahlen, mit immer gleicher Endsumme
11.08.2023 21:35:11
Daniel
Ich hatte eigentlich auch mit den 200 getestet..
Selbst wenn die Makros gleich schnell sein sollten, dann erkläre mir bitte mal den langen Code.
AW: RAND.UNIQ
10.08.2023 20:40:50
Klaus F.
Moin,

auch Dir ein Danke. Aber in Excel 2010 wohl noch nicht gebräuchlich(?)

Gruß
Klaus
richtig. Nur XL 365 und XL Web (kostenlos für alle)
10.08.2023 20:44:12
lupo1
XL Web - sicher?
10.08.2023 21:30:12
daniel
die Lambdas muss man doch bei Namen eintragen und die gibts in XLWeb nicht.
oder habe ich das falsch verstanden?
Da gibt es zwei Möglichkeiten
12.08.2023 08:09:24
lupo1
1. Man lässt jmd. anders den Namen in XL365 definieren und öffnet die Datei dann in XLWeb. Das ist natürlich unpraktisch, weil man sich von dem anderen abhängig macht. Außerdem kann man den Namen im Nachgang selbst nicht ändern.

Daher die Abhilfe:

2. Alle LAMBDAs funktionieren auch unbenannt direkt in der Zelle. Sogar rekursive! Dafür muss man sich die rekursive Argumenten-Definition (das funktioniert mit Doppelungen) genau anschauen. Hier ein Beispiel von mir, mit gleich 3 Rekursionen in einer Formel, die dort intern im Code benannt werden:

https://www.office-hilfe.com/support/threads/combinatorics_list-liste-der-permutationen-kombinationen-variationen-in-einer-formel.57791/
Anzeige
AW: 25 Zufallszahlen, mit immer gleicher Endsumme
10.08.2023 17:36:48
Klaus F.
Moin Daniel,

das ist ein guter Ansatz, werde mal mein Glück probieren ...

Vielen Dank!
Klaus

227 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Links zu Excel-Dialogen

Anzeige

Infobox zum Thema

EXCEL - 25 Zufallszahlen mit immer gleicher Endsumme


Inhaltsverzeichnis


Die Fragestellung


Du möchtest in Excel 25 Zufallszahlen generieren, die in ihrer Summe immer einen bestimmten Wert, zum Beispiel 100, ergeben.


Erläuterung des Problems {#erläuterung-des-problems}


Das Erzeugen von Zufallszahlen in Excel, die eine konstante Summe haben, ist nicht direkt über die Standard-Zufallsfunktionen wie ZUFALLSZAHL() oder ZUFALLSBEREICH() möglich, da diese bei jedem Neuberechnen unterschiedliche Werte liefern. Es muss eine Methode gefunden werden, die Zufallszahlen so anzupassen, dass ihre Summe konstant bleibt.


Lösung des Problems {#lösung-des-problems}


Eine Möglichkeit, dieses Problem zu lösen, ist die Verwendung eines iterativen Ansatzes, bei dem zunächst Zufallszahlen generiert und dann so angepasst werden, dass ihre Summe dem gewünschten Endwert entspricht. Hier ist ein Beispiel, wie du dies in VBA umsetzen kannst:

Sub GenerateRandomNumbersWithConstantSum()
    Dim Numbers(1 To 25) As Double
    Dim Sum As Double
    Dim i As Integer
    Dim TargetSum As Double
    TargetSum = 100 ' Die gewünschte Summe der Zahlen

    ' Zufallszahlen generieren
    For i = 1 To 25
        Numbers(i) = Rnd()
        Sum = Sum + Numbers(i)
    Next i

    ' Anpassen der Zahlen, damit ihre Summe gleich TargetSum ist
    For i = 1 To 25
        Numbers(i) = Numbers(i) / Sum * TargetSum
    Next i

    ' Zahlen in Excel schreiben
    For i = 1 To 25
        Cells(i, 1).Value = Numbers(i)
    Next i
End Sub

Dieses Skript generiert 25 Zufallszahlen, passt ihre Werte an, so dass ihre Summe 100 ergibt, und schreibt sie dann in die erste Spalte des aktuellen Arbeitsblatts.


Anwendungsbeispiele aus der Praxis


  • Budgetplanung: Verteilung eines festen Budgets auf verschiedene Abteilungen oder Projekte.
  • Simulationen: Erstellung von Datensätzen für Simulationszwecke, bei denen die Gesamtsumme konstant bleiben muss.

Tipps


  • Beachte, dass die Verwendung der Rnd()-Funktion ohne Initialisierung des Zufallszahlengenerators mit Randomize dazu führen kann, dass bei jedem Start von Excel die gleiche Zahlenfolge generiert wird.
  • Die generierten Zahlen sind gleichmäßig verteilt. Wenn du eine andere Verteilung benötigst, musst du den Algorithmus entsprechend anpassen.

Verwandte Themenbereiche


  • VBA-Programmierung
  • Statistische Analyse
  • Zufallszahlen in Excel

Zusammenfassung


Die Generierung von 25 Zufallszahlen mit einer konstanten Summe in Excel kann durch ein VBA-Skript erreicht werden, das die Zahlen zunächst generiert und dann so anpasst, dass ihre Summe einem festgelegten Wert entspricht. Dies kann für Budgetierungs- und Simulationszwecke nützlich sein und ermöglicht eine flexible Datenmanipulation für verschiedene Anwendungsfälle.

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige