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 (Archiv)
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

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige