AW: Längste alphabetische Reihe in Worten
17.02.2019 22:37:14
fcs
Hallo Toni,
per Formellät sich das nur mit Hilfsspalten und/oder komplexen Matrix-Formeln lösen.
Deswegen hier eine Lösung mit benutzerdefinierter VBA-Funktion bzw. Makro.
LG
Franz
Option Explicit
'Code in einem allgemeinne Modul der Datei
Public Function fncABC_max(varTexte As Variant, Optional a_Start As Boolean = True, _
Optional bolAnzahl As Boolean = False) As Variant
'varTexte = Zellbereich oder Daten-Array mit den auszuwertenden Texten
'a_Start = wenn WAHR (True), dann werden nur Zeichenfolgen berücksichtigt, die mit a" oder "A" _
beginn
'bolAnzahl = wenn WAHR wird die max. Länge der Zeichenkette als Ergebnis angezeigt, sonst die _
Texte mit _
der längsten Zeichenkette
'Formel-Beispiele
'Zeichenfolgen beginnend mit "a", "A"
'=fncABC_max(A1:B5)
'=fncABC_max(A1:B5;WAHR;WAHR)
'beliebige Zeichenfolgen
'=fncABC_max(A1:B5;FALSCH)
'=fncABC_max(A1:B5;FALSCH;WAHR)
Dim a_max As Integer, iZeichen As Integer
Dim varItem
Dim varTest, strErgebnis As String
Dim iLen As Integer, bolA As Boolean
Dim sAlt As String, sNeu As String
strErgebnis = ""
For Each varItem In varTexte
varTest = LCase(varItem)
sAlt = ""
sNeu = ""
iLen = 0
bolA = False
If a_Start = True Then
'nur Zeichenfolgen berücksichtigen, die mit "a" oder "A" beginnen
For iZeichen = 1 To Len(varTest)
sNeu = Mid(varTest, iZeichen, 1)
Select Case Asc(sNeu)
Case Asc("a") To Asc("z")
If a_Start = True And sNeu = "a" Then
iLen = 1: bolA = True
ElseIf sAlt = "" Then
iLen = 1
Else
If Asc(sNeu) - Asc(sAlt) = 1 And bolA = True Then
iLen = iLen + 1
Else
iLen = 0
bolA = False
End If
End If
If iLen > a_max Then
a_max = iLen: strErgebnis = varItem
ElseIf iLen = a_max And InStr(strErgebnis, varItem) = 0 Then
strErgebnis = strErgebnis & ", " & varItem
End If
sAlt = sNeu
Case Asc("-")
'diese Zeichen bei Auswertung überspringen
Case Else
sAlt = "": iLen = 0: bolA = False
End Select
Next
Else
'beliebige Zeichenfolgen berücksichtigen
For iZeichen = 1 To Len(varTest)
sNeu = Mid(varTest, iZeichen, 1)
Select Case Asc(sNeu)
Case Asc("a") To Asc("z")
If sAlt = "" Then
iLen = 1
Else
If Asc(sNeu) - Asc(sAlt) = 1 Then
iLen = iLen + 1
Else
iLen = 1
End If
End If
If iLen > a_max Then
a_max = iLen: strErgebnis = varItem
ElseIf iLen = a_max And InStr(strErgebnis, varItem) = 0 Then
strErgebnis = strErgebnis & ", " & varItem
End If
sAlt = sNeu
Case Asc("-")
'diese Zeichen bei Auswertung überspringen
Case Else
sAlt = "": iLen = 0
End Select
Next
End If
Next
If bolAnzahl = True Then
fncABC_max = a_max
Else
fncABC_max = strErgebnis
End If
End Function
'Makro-Beispiel
Sub prcLaengsteKette_A1_B5()
Dim varText
varText = fncABC_max(ActiveSheet.Range("A1:B5"), a_Start:=True)
MsgBox "Text mit längster Zeichenfolge beginnend mit A oder a:" & vbLf & varText
varText = fncABC_max(ActiveSheet.Range("A1:B5"), a_Start:=False)
MsgBox "Text mit beliebiger längster Zeichenfolge:" & vbLf & varText
End Sub