Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1104to1108
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro für Kombination, Summe Primzahlen

Makro für Kombination, Summe Primzahlen
alifa
Hallo,
das Problem: 30 vierstellige Zahlen sollen zu je 4 kombiniert werden (Kombination ohne Wiederholung) Gibt 27405 Kombinationen. Gebraucht werden nur die 4, deren Summe jeweils eine Primzahl ist. Ich schätze, das könnten einige Hundert (Vierer-Gruppen)sein. Ich quäle mich mit dem Makro, doch es klappt nicht. Vielleicht kann mir jemand helfen!
Gruß, Erhard

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Rückfrage
04.10.2009 18:05:06
Daniel
HI
an welcher Ecke klemmts den?
bei der Ermittlung der Primzahlen oder beim Erstellen der Kombinationen?
wie sieht dein bisheriges Ergebnis aus, kannst du mal ne Beispieldatei mit deinem bisherigen Ergebnis hochladen?
Gruß, Daniel
AW: Rückfrage
04.10.2009 19:38:41
alifa

Sub SummeVierIstPrimzahl()
Dim i As Long, u As Double, lngR As Long
Dim n As Byte, k As Byte, j As Byte
Dim vSrc, t!
t = Timer
'Einträge:
vSrc = Array(1296, 1225, 1296, 1369, 1444, 1521, 1600, 1681, 1764, 1849, _
1936, 2025, 2116, 2209, 2304, 2401, 2500, 26012704, 2809, 2916, 3025, 3136, _
3249, 3364, 3481, 3600, 3721, 3844, 3969)
k = 4
n = UBound(vSrc) + 1
If k > n Then MsgBox "k > n", 16: Exit Sub
With Application
u = .Fact(n) / (.Fact(k) * .Fact(n - k))
End With
If u > Rows.Count Then MsgBox u & " > " & Rows.Count, 16: Exit Sub
ReDim vRes(k - 1)
ReDim bPos(k - 1) As Byte
For i = 1 To k
bPos(i - 1) = i
Next
Application.ScreenUpdating = False
With ActiveSheet
.Cells.Delete
For i = 1 To u
lngR = lngR + 1
For j = 0 To UBound(bPos)
vRes(j) = vSrc(bPos(j) - 1)
Next
.Range(.Cells(lngR, 1), .Cells(lngR, k)).Value = vRes
Call GetComb(n, k, bPos)
Next
End With
Application.ScreenUpdating = True
MsgBox "fertig in " & Round(Timer - t, 2) & " Sek "
End Sub


Sub GetComb(ByVal n As Byte, ByVal k As Byte, bPos() As Byte)
Dim i As Byte, j As Byte
i = k - 1
Do While bPos(i) >= n - k + i + 1
If i = 0 Then Exit Do
i = i - 1
Loop
bPos(i) = bPos(i) + 1
For j = i To k - 1
bPos(j) = bPos(i) + j - i
Next
End Sub
Es sollen aber nur DIE Kombinationen in die Tabelle geschrieben werden, deren Summe eine Primzahl ergibt.Z.B.1849+2116+2401+3025=9391
Anzeige
AW: Rückfrage
04.10.2009 20:45:26
Daniel
HI
da musst du doch eigentlich nur noch eine Primzahlprüfung einbauen:
Option Explicit
Sub SummeVierIstPrimzahl()
Dim i As Long, u As Double, lngR As Long
Dim n As Byte, k As Byte, j As Byte
Dim vSrc, t!
t = Timer
'Einträge:
vSrc = Array(1296, 1225, 1296, 1369, 1444, 1521, 1600, 1681, 1764, 1849, _
1936, 2025, 2116, 2209, 2304, 2401, 2500, 2601, 2704, 2809, 2916, 3025, 3136, _
3249, 3364, 3481, 3600, 3721, 3844, 3969)
k = 4
n = UBound(vSrc) + 1
If k > n Then MsgBox "k > n", 16: Exit Sub
With Application
u = .Fact(n) / (.Fact(k) * .Fact(n - k))
End With
If u > Rows.Count Then MsgBox u & " > " & Rows.Count, 16: Exit Sub
ReDim vres(k - 1)
ReDim bPos(k - 1) As Byte
For i = 1 To k
bPos(i - 1) = i
Next
Application.ScreenUpdating = False
With ActiveSheet
.Cells.Delete
For i = 1 To u
For j = 0 To UBound(bPos)
vres(j) = vSrc(bPos(j) - 1)
Next
If IstSummePrim(vres) Then
lngR = lngR + 1
.Range(.Cells(lngR, 1), .Cells(lngR, k)).Value = vres
End If
Call GetComb(n, k, bPos)
Next
End With
Application.ScreenUpdating = True
MsgBox "fertig in " & Round(Timer - t, 2) & " Sek "
End Sub
Function IstSummePrim(a) As Boolean
Dim Summe As Long
Dim x As Long
Summe = WorksheetFunction.Sum(a)
For x = 2 To Int(Sqr(Summe))
If Summe Mod x = 0 Then Exit For
Next
IstSummePrim = x > Int(Sqr(Summe))
End Function
Sub GetComb(ByVal n As Byte, ByVal k As Byte, bPos() As Byte)
Dim i As Byte, j As Byte
i = k - 1
Do While bPos(i) >= n - k + i + 1
If i = 0 Then Exit Do
i = i - 1
Loop
bPos(i) = bPos(i) + 1
For j = i To k - 1
bPos(j) = bPos(i) + j - i
Next
End Sub
Gruß, Daniel
Anzeige
AW: Rückfrage
04.10.2009 21:38:56
alifa
Hallo Daniel,
danke, Du hast mir sehr geholfen. Das Makro funktioniert einwandfrei!
Gruß, Erhard

306 Forumthreads zu ähnlichen Themen


Hallo zusammen.
Gibt es über VBA eine Möglichkeit, die Hintergrundfarbe einer Zelle in eine Zahl umzuwandeln und das schneller als mit for- Schleifen?
Habe einen Bereich ("J16:AG39"), wo ich per Zellaktivierung mit der Maus Zellen oder auch Zellbereiche mit einer Hintergrundfarbe verseh...
Anzeige

Hi Formelspezialisten,
in Zelle B2 steht dise Formel (funktionert auc h):
=TEXT(I4-D4;"00.0")&" ("&TEXT(I4/D4-1;"0%")&")".
Mein Ziel, dass eine Minuszahl in ROT erscheint. Hab's mit bedingte Formatierung versucht und bekomme es nicht hin.
Gibt es eine Möglichkeit, a...

Hallo,
ein ähnliches Problem wurde hier im Forum schon einmal diskutiert. (https://www.herber.de/forum/archiv/632to636/t635773.htm)
Meine Problem:
Wie kann ich die Anzahl unterschiedlicher Einträge/Werte einer Spalte erhalten, ohne dass diese vorgegeben werden ( also ohne die Verwe...
Anzeige

Hall Leute!
ich will nach einem Begriff, in meinem Fall nach "SUMs" in der Spalte C suchen und wissen wie oft es in der Spalte vorkommt.
Bei Berechnungen funktioniert es mit ZÄHLENWENN ohne Probleme aber wie erhalte ich die "absolute" Zahl?
Vielen Dank für Eure Hilfe!
Grüße
...

Guten Morgen!
Ich habe in einem Arbeitsblatt mehrere Tabellen.
In einer UserForm habe habe ich 460 TextBoxen, wobei die Zählung immer pro Reihe senkrecht erfolgt.
Spalte 1 = TextBox1-23, Spalte2 = TextBox24- TextBox46 usw.
Ich möchte nun z.B. die erste Tabelle in die Textboxen e...
Hallo,
in einer Telefontabelle, welche sich ständig ändert, möchte ich die ersten 4 Ziffern der Rufnummer per Makro rot einfärben.
Hat jemand eine gute Idee?
https://www.herber.de/bbs/user/54765.xls
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige