Hi Erhard,
jetzt hoffe ich es verstanden zu haben. Und ich hoffe, dass diese Prozeduren
die richtigen Ergebnisse liefern:
Option Explicit
Dim nn As Long, kk As Long, txt As String
Dim vA As Integer, vTxt, vZah
Sub aStart()
Dim ii As Long, zz As Long, anr As Long, arE(), arF()
nn = 26
kk = 5
vA = Cells(Rows.Count, 5).End(xlUp).Row
vTxt = Cells(1, 5).Resize(vA) ' Prüfwörter
vZah = Cells(1, 6).Resize(vA, 2) ' Prüfzahlen
ReDim arE(1 To nn ^ kk)
For ii = 1 To nn
txt = txt & Chr(ii + 64) ' Alphabet
Next ii
Variat "", zz, arE ' 1. Aufruf
If zz > 0 Then
ReDim Preserve arF(1 To zz, 0)
For ii = 1 To zz
arF(ii, 0) = arE(ii)
Next ii
Cells(1, 1).Resize(zz) = arF
Else
Cells(1, 1) = "nix rausgekommen"
End If
Application.StatusBar = False
End Sub
Sub Variat(Erg As String, Ze As Long, arE)
Dim ii As Long, ee As String, pp As Integer, qq As Integer
Dim rr As Integer, ch1 As Integer, ch2 As Integer, tt As String
Dim vvT() As String
ReDim vvT(1 To vA)
For ii = 1 To nn ' Schleife 26 Buchstaben
If Len(Erg) vZah(rr, 1) Then Exit For
End If
Next pp
For pp = 1 To kk ' Schleife 5 Stellen/Prüfwort
For qq = 1 To kk ' Schleife 5 Stellen/Wort
If Mid(ee, qq, 1) = Mid(vvT(rr), pp, 1) Then
ch2 = ch2 + 1
Mid(ee, qq, 1) = "#"
Mid(vvT(rr), pp, 1) = "$"
If ch2 > vZah(rr, 2) Then Exit For
End If
Next qq
If qq vZah(rr, 1) Or ch2 vZah(rr, 2) Then Exit For
Next rr
If rr > vA Then ' evtl. Ausgabe in Array
Ze = Ze + 1
arE(Ze) = tt
' If Ze Mod 10 = 0 Then
' Application.StatusBar = arE(Ze) & " - " & Ze
' DoEvents
' End If
End If
End If
Next ii
End Sub
Function check(tt As String) As Boolean
Dim ee As String, vA As Integer, vTxt, kk As Integer
Dim rr As Integer, ch1 As Integer, ch2 As Integer
Dim pp As Integer, qq As Integer
Dim vvT() As String
vA = Cells(Rows.Count, 5).End(xlUp).Row
ReDim vvT(1 To vA)
kk = 5 ' Wortlänge
vTxt = Cells(1, 5).Resize(vA) ' 6 Prüfwörter
vZah = Cells(1, 6).Resize(vA, 2) ' 6*2 Prüfzahlen
For rr = 1 To vA ' Schleife 6 Prüfworte
For pp = 1 To vA
vvT(pp) = vTxt(pp, 1) ' Prüfwörter-Init
Next pp
ee = tt
ch1 = 0
ch2 = 0
For pp = 1 To kk ' Schleife 5 Stellen/Prüfwort
If Mid(ee, pp, 1) = Mid(vvT(rr), pp, 1) Then
ch1 = ch1 + 1
Mid(ee, pp, 1) = "#"
Mid(vvT(rr), pp, 1) = "$"
If ch1 > vZah(rr, 1) Then Exit For
End If
Next pp
For pp = 1 To kk ' Schleife 5 Stellen/Prüfwort
For qq = 1 To kk ' Schleife 5 Stellen/Wort
If Mid(ee, qq, 1) = Mid(vvT(rr), pp, 1) Then
ch2 = ch2 + 1
Mid(ee, qq, 1) = "#"
Mid(vvT(rr), pp, 1) = "$"
If ch2 > vZah(rr, 2) Then Exit For
End If
Next qq
If qq vZah(rr, 1) Or ch2 vZah(rr, 2) Then Exit For
Next rr
If rr > vA Then check = True
End Function
Für alle Prozeduren, auch das check, müssen in E1:E6 die Prüfwörter (5 Buchstaben)
und in F1:F6 die Anzahlen "Gleichheit bei selber Position"
und in G1:G6 die Anzahlen "Gleichheit bei unterschiedl. Position" stehen.
(Es können auch mehr oder weniger als 6 Prüfwörter sein.)
Der Code ist nicht laufzeit-optimiert, geht aber doch einigermaßen flott.
Das kommt z. B. raus:
| | A | B | C | D | E | F | G |
| 1 | LISTE | WAHR | | | LAGER | 1 | 1 |
| 2 | | | | | STALL | 0 | 3 |
| 3 | | | | | ROLLE | 1 | 1 |
| 4 | | | | | SENIL | 0 | 4 |
| 5 | | | | | DIESE | 2 | 1 |
| 6 | | | | | STUBE | 1 | 2 |
| 7 | | | | | | | |
LISTE ist wohl das einzige Resultat bei den Vorgaben in E1:G6.
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich