Zahlenreihe mit mehrfachen Ziffern finden

Hallo,
ich suche aus einer Zahlenreihe von 1 bis 2.000.000 alle Zahlen, die eine einzelne Ziffer mindestens 4-mal beinhalten.
Also z.B.
113411
300333
909199
Grundsätzlich habe ich bereits eine Lösung mit Formeln gefunden:
Tabelle1

	A	B	C	D	E	F
1		1	2	3	4	5
2	1000	1	0	0	0
3	1211	1	2	1	1
4	4444	4	4	4	4
5	12111	1	2	1	1	1

Formeln der Tabelle

Zelle	Formel
B2	=TEIL($A2;SPALTE()-1;1)
C2	=TEIL($A2;SPALTE()-1;1)
D2	=TEIL($A2;SPALTE()-1;1)
E2	=TEIL($A2;SPALTE()-1;1)
F2	=TEIL($A2;SPALTE()-1;1)
B3	=TEIL($A3;SPALTE()-1;1)
C3	=TEIL($A3;SPALTE()-1;1)
D3	=TEIL($A3;SPALTE()-1;1)
E3	=TEIL($A3;SPALTE()-1;1)
F3	=TEIL($A3;SPALTE()-1;1)
B4	=TEIL($A4;SPALTE()-1;1)
C4	=TEIL($A4;SPALTE()-1;1)
D4	=TEIL($A4;SPALTE()-1;1)
E4	=TEIL($A4;SPALTE()-1;1)
F4	=TEIL($A4;SPALTE()-1;1)
B5	=TEIL($A5;SPALTE()-1;1)
C5	=TEIL($A5;SPALTE()-1;1)
D5	=TEIL($A5;SPALTE()-1;1)
E5	=TEIL($A5;SPALTE()-1;1)
F5	=TEIL($A5;SPALTE()-1;1)

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8
Zuerst teile ich alle Zahlen auf Ziffern auf, dann suche mit Zählenwenn wie oft einzelne Ziffern vorkommen und zuletzt filtere ich dann alle Zeilen bei denen einzelne Ziffern mind. 4x vorkommen!!
Allerdings ist das äußerst aufwändig und sprengt fast die Ressource der EXCEL-Datei.
Jetzt dachte, dass es evtl. einen Code gibt, der von 1 - 2.000.000 alle betroffenen Zahlen aufsteigend sortiert auflistet. Ggfls. macht es Sinn den Code aufzuteilen in
1 - 500.000
500.001 - 1.000.000
usw.
Vielen Dank für Lösungsvorschläge.
mfg

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
die anderen Fragesteller waren nicht so interessant...
Der Code benötigt 20 Sekunden, es macht also keinen Sinn, sich Gedanken um etwas schnelleres zu machen.
Sub vierStellen() 'bestimmt 4 gleiche Ziffern in Zahl bis 2 Mio Anf = Timer Dim Ar() Dim i As Long With CreateObject("scripting.dictionary") For L = 5 To 7 O = 10 ^ L O = IIf(L = 7, 2000000, O) For i = 10 ^ (L - 1) To O If Pruef4(i, L - 4) Then y = .Item(i) Next i Next L Debug.Print .Count Arr = .keys ReDim Ar(.Count + 1, 0) For i = 0 To UBound(Arr): Ar(i, 0) = Arr(i): Next i Range("A1").Resize(.Count + 1, 1) = Ar End With Debug.Print Timer - Anf End Sub Function Pruef4(ByVal i As Long, L As Integer) As Boolean For ii = 0 To 9 If i ii Then If Len(Replace(i, ii, "")) = L Then Pruef4 = True: Exit Function End If Next ii End Function mfg

Sub xxx() Dim vgl(9, 1) As String Dim i As Long, v As Long, z As Long, t As String Dim arr Dim a Const von As Long = 10000 Const bis As Long = 2000000 ReDim arr(von To bis) As Long For v = 0 To 9 vgl(v, 0) = "*" & WorksheetFunction.Rept(v & "*", 4) vgl(v, 1) = vgl(v, 0) & v & "*" Next For i = von To bis t = CStr(i) For v = 0 To 9 If t Like vgl(v, 0) Then If Not t Like vgl(v, 1) Then arr(von + z) = t z = z + 1 Exit For End If End If Next Next ReDim Preserve arr(von To von + z - 1) arr = WorksheetFunction.Transpose(arr) Cells(1, 2).Resize(UBound(arr, 1) - LBound(arr, 2) + 1, 1) = arr End Sub

Beliebteste Forumthreads (12 Monate)

Zahlenreihe mit mehrfachen Ziffern finden

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread