Kennzahl ermitteln

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Function KennzahlOK(zz As String, kk As Integer) As Boolean KennzahlOK = KennZahl(zz) = kk End Function Function KennZahl(zz As String) As Integer Dim ii As Integer, tt As String, pp As Integer, ee As Integer For ii = 1 To 3 tt = WorksheetFunction.Rept(CStr(ii), ii) pp = InStr(zz, tt) While pp If Mid(zz & "X", pp + ii, 1) tt Then ee = ee + ii pp = InStr(pp + ii + 1, zz, tt) Wend Next ii KennZahl = ee End Function Function KennzRichtig(zz As String, kk As Integer) As Boolean Dim ii As Integer, tt As String, pp As Integer, ee As Integer For ii = 1 To 3 tt = WorksheetFunction.Rept(CStr(ii), ii) pp = InStr(zz, tt) While pp If Mid(zz & "X", pp + ii, 1) tt Then ee = ee + ii pp = InStr(pp + ii + 1, zz, tt) Wend If ee > kk Then Exit For Next ii KennzRichtig = kk = ee End Function

Hi Erhard,
da hatte ich nur nach vorn geschaut, wobei doch Rücksicht genauso wichtig ist. :-)
Nicht nur dein Beispiel - Zeile 7 war auch falsch.
Hier mein 2. Vorschlag:

	A	B	C	D	E
1	Vorgaben		gerechnet
2	Zahl	Kennzahl	richtig	Kennzahl	OK
3	1223331	7	WAHR	7	WAHR
4	1223332	6	WAHR	6	WAHR
5	1234567	1	WAHR	1	WAHR
6	1233233	1	WAHR	1	WAHR
7	1122233	0	WAHR	0	WAHR
8	1122312	4	FALSCH	3	FALSCH
9	3331221	6	FALSCH	7	FALSCH
10	1113331	5	FALSCH	4	FALSCH
11	1113331	4	WAHR	4	WAHR

Formeln der Tabelle

Zelle	Formel
C3	=KennzRichtig(A3;B3)
D3	=KennZahl(A3)
E3	=KennzahlOK(A3;B3)

Und der Code:


Function KennZahl(zz As String) As Integer
Dim ii As Integer, tt As String, pp As Integer, ee As Integer
For ii = 1 To 3
tt = WorksheetFunction.Rept(CStr(ii), ii)
pp = InStr(zz, tt)
While pp
If Mid("X" & zz, pp, ii)  tt And _
Mid(zz & "X", pp + 1, ii)  tt Then ee = ee + ii
pp = InStr(pp + ii + 1, zz, tt)
Wend
Next ii
KennZahl = ee
End Function
Function KennzRichtig(zz As String, kk As Integer) As Boolean
Dim ii As Integer, tt As String, pp As Integer, ee As Integer
For ii = 1 To 3
tt = WorksheetFunction.Rept(CStr(ii), ii)
pp = InStr(zz, tt)
While pp
If Mid("X" & zz, pp, ii)  tt And _
Mid(zz & "X", pp + 1, ii)  tt Then ee = ee + ii
pp = InStr(pp + ii + 1, zz, tt)
Wend
If ee > kk Then Exit For
Next ii
KennzRichtig = kk = ee
End Function

Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

Option Explicit Sub schleifchen() Dim jj As Long, zz As Long, ss As String For jj = 0 To 5000 ss = CStr(Dez2Basis(jj, 3) + 1111111) If Len(ss) > 7 Then Exit For If KennZahl(ss) = 7 Then zz = zz + 1: Cells(zz, 1) = ss Next jj End Sub Function Dez2Basis(ByVal Zahl As Long, basis As Integer) As String ' basis max. 16 Dim mask As Long, h mask = 1 h = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, "A", "B", "C", "D", "E", "F") Do mask = Zahl Mod basis Zahl = Int(Zahl / basis) Dez2Basis = h(mask) & Dez2Basis Loop Until Zahl

Sub schleifchen1() Dim jj As Long, zz As Long, ss As String Dim s1$ For jj = 0 To 5000 ss = CStr(Dez2Basis(jj, 3) + 1111111) If Len(ss) > 7 Then Exit For If KennZahl(ss) = 7 Then zz = zz + 1 If Mid$(ss, 5, 1) 2 Then ss = "" Cells(zz, 5) = ss End If: Next jj End Sub

Sub schleifchen2() Dim jj As Long, zz As Long, ss As String Dim s1$ For jj = 0 To 5000 ss = CStr(Dez2Basis(jj, 3) + 1111111) If Len(ss) > 7 Then Exit For If KennZahl(ss) = 7 Then If Mid$(ss, 5, 1) = 2 Then zz = zz + 1 Cells(zz, 5) = ss End If End If Next jj End Sub Sub schleifchen3() Dim jj As Long, zz As Long, ss As String Dim s1$ For jj = 0 To 5000 ss = CStr(Dez2Basis(jj, 3) + 1111111) If Len(ss) > 7 Then Exit For If KennZahl(ss) = 7 And Mid$(ss, 5, 1) = 2 Then zz = zz + 1 Cells(zz, 5) = ss End If Next jj End Sub

Sub schleifchen() Dim xLen As Long, xZif As Integer, xSol As Long Dim xEin As String, xPos As Integer, bolJ As Boolean Dim jj As Long, zz As Long, ss As String xLen = Cells(2, 4) xZif = Cells(3, 4) xSol = Cells(4, 4) xEin = Cells(5, 4) xPos = Cells(6, 4) Columns(1).Resize(, 2).ClearContents For jj = 0 To 3000000 ss = CStr(0 + Dez2Basis(jj, xZif) + WorksheetFunction.Rept("1", xLen)) If Len(ss) > xLen Then Exit For If KennZahlX(ss, xZif) = xSol Then bolJ = False If xEin = "0" Or xPos = 0 Then bolJ = True ElseIf Mid(ss, xPos, 1) = xEin Then bolJ = True End If If bolJ Then zz = zz + 1 Cells(zz, 1) = ss Cells(2, 2) = zz Cells(4, 2) = ss DoEvents End If End If Next jj End Sub

Beliebteste Forumthreads (12 Monate)

	A	B	C	D	E
1	121333122			Vorgaben
2	122122322	33	Länge	9
3	122133312		Ziffern	3
4	122322122	333233322	Kennzahl	8
5	131333122		mit Ziffer	2	oder 0
6	132233322		an Position	9	oder 0
7	133312122
8	133312212
9	133313122
10	133313332
11	133322322
12	212233322

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Kennzahl ermitteln

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread