Ja, kann ich, aber wie geschrieben, die ...
24.01.2012 06:18:23
Luc:-?
…Fkt sollte idR in einer TabBlatt-Formel verwendet wdn, Walter,
und ist deshalb in einem allgemeinen Modul der Mappe (oder deiner/m persönl Makro-Sammel-Datei bzw -AddIn) zu speichern. Folgende Fml könnte dann im TabBlatt verwendet wdn, um beide Werte auf 1x zurückzugeben (kann auch anders gemacht wdn — probier mal!):
{=--TEIL(A2;{1;0}+{0;1}*VLike(A2;"*0000[1-9]*";-1);{-5;99}+{1;0}*VLike(A2;"*0000[1-9]*";1))}
Das ist eine MatrixFml*, die sich über 2 Zellen einer Spalte erstreckt. Die inneren {} umschließen Matrixkonstanten, müssen also mit eingegeben wdn, die äußeren nicht → sie entstehen bekanntlich automatisch*. Falls du die Werte in 2 Zellen einer Zeile ausgeben willst, musst du die ; der Matrixkonstanten durch . ersetzen, also zB {1.0}+{0.1}…
*Bitte ggf in der xlHilfe nachlesen!
Den hier folgenden Korpus der udFkt wie beschrieben speichern:
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.2 -LSr.CyWorXxl -cd: 20120121 -fpub: 20120124 herber.de -lupd: 20120121n
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
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
Die PgmTeile, die bei dir nicht fktn würden, habe ich auskommentiert. Das ist mit einer gewissen Einschränkung der Universalität der Fkt verbunden, aber ich glaube, damit kannst du leben.
Gruß Luc :-?