Nebenbei, für UDF-/Formel-Interessenten!
03.02.2017 01:24:36
Luc:-?
Eine MatrixFml mit UDF-Unterstützung könnte für das konkrete Bsp (mit 6 TeilTexten) so aussehen:
{=VJoin(WENN(TxEval(WECHSELN("VLike(index("&VJoin(VSplit(A1;", ");",;";2)&",@),""A TXT #*"")";"@"; ZEILE(A1:A6)));"";VSplit(A1;", "));", ";-1) }
Für beliebig viele TeilTexte eher so:
{=VJoin(WENN(TxEval(WECHSELN("VLike(index("&VJoin(VSplit(A1;", ");",;";2)&",@),""A TXT #*"")";"@"; ZEILE(INDIREKT("A1:A"&ANZAHL2(VSplit(A1;", "))))));"";VSplit(A1;", "));", ";-1) }
Bezogen auf einen GesamtText in A1. Das ist aber auch einfacher möglich, wenn zusätzlich MTRANS eingesetzt wird (muss wohl noch ein „Horizontal-bug“, der beim Auswerten des FmlTextes wg INDEX nicht auftreten kann, in der UDF stecken):
{=VJoin(WENN(VLike(MTRANS(VSplit(I14;", "));"A TXT #*");"";MTRANS(VSplit(I14;", ")));", ";-1)}
UDF-Links:
TxEval: https://www.herber.de/cgi-bin/callthread.pl?index=1476498#1477400
VJoin & VSplit: https://www.herber.de/bbs/user/99024.xlsm
Da der Thread von 2012 mit dem Pgm von VLike beim Archiv-Umbau 2016 verloren gegangen zu sein scheint, nutze ich die Gelegenheit und poste ihn hier erneut:
Rem Mxfmlfäh udFkt vgleicht Arg1 m.Suchmaske(Arg2) u.liefert Ergeb lt Arg3
' Arg3=0(fehlt)->Wahrheitswt, =-1/+1->Anfangs-/EndPosition d.letzt Arg1-
' TeilZeichenkette, f.d.sich noch 1 Vgl-Treffer ergibt. Mehr als 1 Tref-
' fer liegt vor, falls Anfangs- > EndPosition ist! Arg2/3 müssen Skalare
' sein or Arg1-Dimension haben, wobei Arg1 dann nur Vektor sein darf. In
' dsn Fällen wird udFkt VPairs benötigt ->ggf d.PgmTeil auskommentieren!
' Wn Arg1 Skalar ist, darf Arg2 ODER Arg3 ebenfalls beliebg Vektor sein.
' Vs1.3 -LSr.CyWorXxl -cd: 20120121 -fpub: 20120124 herber.de -lupd: 20160803n
Function VLike(ByVal Bezug, ByVal TxMaske, Optional ByVal TxPosit = 0)
Dim cix As Long, lb(1) As Long, pix As Long, rix As Long, ub(1) As Long, _
lm(1) As Long, lp(1) As Long, um(1) As Long, up(1) As Long, _
hVkt(2) As Boolean, avBez, erg(), txm, txp, xB As Variant
On Error Resume Next
If IsArray(TxMaske) Then
If TypeName(TxMaske) = "Range" Then
VLike = CVErr(xlErrRef)
With WorksheetFunction
TxMaske = .Transpose(.Transpose(TxMaske.Value2))
End With
Else: VLike = CVErr(xlErrNum)
End If
If IsError(LBound(TxMaske, 2)) Then
hVkt(1) = True: lm(0) = LBound(TxMaske): um(0) = UBound(TxMaske)
If um(0) - lm(0) = 0 Then txm = TxMaske(lm(0)) _
Else txm = TxMaske
Else: lm(0) = LBound(TxMaske, 2): um(0) = UBound(TxMaske, 2)
lm(1) = LBound(TxMaske, 1): um(1) = UBound(TxMaske, 1)
If um(0) - lm(0) = 0 Then
If um(1) - lm(1) = 0 Then txm = TxMaske(lm(1), lm(0)) _
Else txm = TxMaske
Else: Exit Function
End If
End If
Else: txm = TxMaske
End If
If IsArray(TxPosit) Then
If TypeName(TxPosit) = "Range" Then
VLike = CVErr(xlErrRef)
With WorksheetFunction
TxPosit = .Transpose(.Transpose(TxPosit.Value2))
End With
Else: VLike = CVErr(xlErrNum)
End If
If IsError(LBound(TxPosit, 2)) Then
hVkt(2) = True: lp(0) = LBound(TxPosit): up(0) = UBound(TxPosit)
If up(0) - lp(0) = 0 Then txp = TxPosit(lp(0)) _
Else txp = TxPosit
Else: lp(0) = LBound(TxPosit, 2): up(0) = UBound(TxPosit, 2)
lp(1) = LBound(TxPosit, 1): up(1) = UBound(TxPosit, 1)
If up(0) - lp(0) = 0 Then
If up(1) - lp(1) = 0 Then txp = TxPosit(lp(1), lp(0)) _
Else txp = TxPosit
Else: Exit Function
End If
End If
Else: txp = TxPosit
End If
If IsArray(Bezug) Then
If TypeName(Bezug) = "Range" Then
With WorksheetFunction
avBez = .Transpose(.Transpose(Bezug.Value2))
End With
Else: avBez = Bezug
End If
If IsError(LBound(avBez, 2)) Then
lb(0) = LBound(avBez): ub(0) = UBound(avBez)
hVkt(0) = True: ReDim erg(ub(1) - lb(1))
ElseIf IsArray(txm) Or IsArray(txp) Then
If UBound(avBez, 2) - LBound(avBez, 2) = 0 Then
ReDim erg(UBound(avBez, 1) - LBound(avBez, 1), 0)
Else: VLike = CVErr(xlErrRef): Exit Function
End If
Else: lb(0) = LBound(avBez, 2): ub(0) = UBound(avBez, 2)
lb(1) = LBound(avBez, 1): ub(1) = UBound(avBez, 1)
ReDim erg(ub(1) - lb(1), ub(0) - lb(0))
End If
If IsArray(txm) And IsArray(txp) Then
Exit Function
For Each xB In VPairs(avBez, txm, txp)
If Not IsNumeric(xB(2)) Then
TxPosit = CInt(CBool(InStr(xB(2), "-"))) - CInt(CBool(InStr(xB(2), "+")))
Else: TxPosit = Sgn(xB(2))
End If
Bezug = xB(0): TxMaske = xB(1)
VLike = IIf(CBool(TxPosit), 0, False): GoSub ew
Next xB
ElseIf IsArray(txm) Then
Exit Function
If Not IsNumeric(txp) Then
TxPosit = CInt(CBool(InStr(txp, "-"))) - CInt(CBool(InStr(txp, "+")))
Else: TxPosit = Sgn(txp)
End If
For Each xB In VPairs(avBez, txm)
Bezug = xB(0): TxMaske = xB(1)
VLike = IIf(CBool(TxPosit), 0, False): GoSub ew
Next xB
ElseIf IsArray(txp) Then
Exit Function
TxMaske = txm
For Each xB In VPairs(avBez, txp)
If Not IsNumeric(xB(1)) Then
TxPosit = CInt(CBool(InStr(xB(1), "-"))) - CInt(CBool(InStr(xB(1), "+")))
Else: TxPosit = Sgn(xB(1))
End If
Bezug = xB(0): VLike = IIf(CBool(TxPosit), 0, False): GoSub ew
Next xB
Else: TxMaske = txm
If Not IsNumeric(txp) Then
TxPosit = CInt(CBool(InStr(txp, "-"))) - CInt(CBool(InStr(txp, "+")))
Else: TxPosit = Sgn(txp)
End If
For Each Bezug In avBez
VLike = IIf(CBool(TxPosit), 0, False): GoSub ew
Next Bezug
End If
VLike = erg
ElseIf IsArray(txm) And IsArray(txp) Then
Exit Function
ElseIf IsArray(txm) Then
If Not hVkt(1) Then
ReDim erg(um(1) - lm(1), um(0) - lm(0))
Else: ReDim erg(um(0) - lm(0))
End If
If Not IsNumeric(txp) Then
TxPosit = CInt(CBool(InStr(txp, "-"))) - CInt(CBool(InStr(txp, "+")))
Else: TxPosit = Sgn(txp)
End If
avBez = Bezug: hVkt(0) = hVkt(1)
lb(0) = lm(0): ub(0) = um(0): lb(1) = lm(1): ub(1) = um(1)
For Each TxMaske In txm
VLike = IIf(CBool(TxPosit), 0, False): GoSub ew
Next TxMaske
VLike = erg
ElseIf IsArray(txp) Then
If Not hVkt(2) Then
ReDim erg(up(1) - lp(1), up(0) - lp(0))
Else: ReDim erg(up(0) - lp(0))
End If
avBez = Bezug: hVkt(0) = hVkt(2)
lb(0) = lp(0): ub(0) = up(0): lb(1) = lp(1): ub(1) = up(1)
For Each TxPosit In txp
If Not IsNumeric(TxPosit) Then
TxPosit = CInt(CBool(InStr(TxPosit, "-"))) - CInt(CBool(InStr(TxPosit, "+")))
Else: TxPosit = Sgn(TxPosit)
End If
VLike = IIf(CBool(TxPosit), 0, False): GoSub ew
Next TxPosit
VLike = erg
Else: TxMaske = txm
If Not IsNumeric(txp) Then
TxPosit = CInt(CBool(InStr(txp, "-"))) - CInt(CBool(InStr(txp, "+")))
Else: TxPosit = txp
End If
ew: If IsError(Bezug) Then
VLike = Bezug
ElseIf Bezug Like TxMaske Then
Select Case TxPosit
Case -1
For pix = 1 To Len(Bezug)
If Not Mid(Bezug, pix) Like TxMaske Then Exit For
Next pix
VLike = pix - 1
Case 0: VLike = True
Case 1
For pix = Len(Bezug) To 1 Step -1
If Not Left(Bezug, pix) Like TxMaske Then Exit For
Next pix
VLike = pix + 1
End Select
ElseIf TxPosit = 0 Then
VLike = False
End If
If Not IsEmpty(avBez) Then
If Not hVkt(0) Then
erg(rix, cix) = VLike
rix = (rix + 1) Mod (ub(1) + 1 - lb(1))
cix = cix - CInt(rix = 0)
Else: erg(cix) = VLike: cix = cix + 1
End If
Return
End If
End If
End Function
Gruß, Luc :-?
Besser informiert mit …