In VBA kann das so gehen,...
28.02.2010 05:18:50
Luc:-?
…Skaddy…
Rem Autor: LSr\CyWorXxl - CDate:20100227/28 - 1Pub:20100228 Herber
Function PickOn(ByVal Bezug, Optional ByVal Wahl = 1, Optional ByVal _
TrennZ As String = " ", Optional ByVal KritBezug As Boolean = True)
Dim dl As Boolean, i As Long, ug As Long, dt As String, _
ac As Range, bt, bezFeld, ergW(), kritFeld, w As Variant
On Error Resume Next
With Application
dt = .International(xlDecimalSeparator)
If IsError(.Caller.Address) Then _
Set ac = ActiveWindow.RangeSelection Else Set ac = .Caller
End With
If Not IsArray(Wahl) Then
dl = (Left(Wahl, 1) = "-")
If dl Then Wahl = Mid(Wahl, 2)
If Not IsNumeric(Wahl) And Instr(Wahl, dt) = 0 Then
i = 1 - CInt(dl)
While i <= Len(Wahl) And IsNumeric(Mid(Wahl, i, 1)): i = i + 1: Wend
dt = Mid(Wahl, i, 1): i = 0
If dt <> " " Then Wahl = Replace(Wahl, " ", "")
Wahl = Split(Wahl, dt)
ElseIf CBool(Instr(Wahl, dt)) Then
Wahl = Split(Wahl, dt)
End If
Else
With WorksheetFunction
If TypeName(Wahl) = "Range" Then Wahl = .Transpose(Wahl)
If IsError(LBound(Wahl, 2)) Then Else Wahl = .Transpose(Wahl)
If IsError(LBound(Wahl, 2)) Then Else PickOn = CVError(xlErrRef): GoTo ex
End With
dl = (Wahl(LBound(Wahl)) < 0)
End If
If IsArray(Bezug) Then
With WorksheetFunction
If TypeName(Bezug) = "Range" Then
bezFeld = .Transpose(Bezug)
Else: bezFeld = Bezug
End If
If IsError(LBound(bezFeld, 2)) Then Else bezFeld = .Transpose(bezFeld)
If IsError(LBound(bezFeld, 2)) Then Else PickOn = CVError(xlErrRef): GoTo ex
If IsArray(KritBezug) Then
If TypeName(KritBezug) = "Range" Then kritFeld = .Transpose(KritBezug)
If IsError(LBound(kritFeld, 2)) Then Else kritFeld = .Transpose(kritFeld)
If IsError(LBound(kritFeld, 2)) Then Else PickOn = CVError(xlErrRef): GoTo ex
Else: kritFeld = KritBezug
End If
End With
If UBound(bezFeld) <> UBound(kritFeld) Then _
PickOn = CVErr(xlErrRef): GoTo ex
ug = LBound(bezFeld): ReDim ergW(UBound(bezFeld) - ug)
For Each Bezug In bezFeld
If IsArray(kritFeld) Then KritBezug = kritFeld(i + ug)
GoSub ew: ergW(i) = PickOn: i = i + 1
Next Bezug
If ac.Columns.Count = 1 Then
PickOn = WorksheetFunction.Transpose(ergW)
Else: PickOn = ergW
End If
GoTo ex
ElseIf IsArray(KritBezug) Then
PickOn = CVErr(xlErrRef): GoTo ex
End If
ew: If CBool(KritBezug) Then
If dl Then PickOn = Bezug Else PickOn = ""
bt = Split(Bezug, TrennZ)
If IsArray(Wahl) Then
For Each w In Wahl
If Abs(w) > 0 Then
If Abs(w) - 1 > UBound(bt) Then Exit For
If dl Then
PickOn = Replace(Replace(PickOn, bt(Abs(w) - 1), "", 1, 1), _
String(2, TrennZ), TrennZ)
Else: PickOn = PickOn & TrennZ & bt(Abs(w) - 1)
End If
End If
Next w
If Not dl Then PickOn = Mid(PickOn, Len(TrennZ) + 1)
ElseIf Abs(Wahl) - 1 > UBound(bt) Or CLng(Wahl) = 0 Then
PickOn = Bezug
ElseIf dl Then
PickOn = Replace(Replace(PickOn, bt(Abs(Wahl) - 1), "", 1, 1), _
String(2, TrennZ), TrennZ)
Else: PickOn = bt(Abs(w) - 1)
End If
Else: PickOn = Bezug
End If
If Not IsEmpty(bezFeld) Then Return
ex: Set ac = Nothing
End Function
Diese Funktion ist eine sog udF und kann im TabBlatt eingesetzt wdn. Sie verlangt mindestens 1 und maximal 4 Argumente…
Arg1: erforderlich; der Bezug auf eine Zelle bzw einen Zellbereich (als Matrixformel) oder ein Datenfeld als Ergebnis eines Ausdrucks.
Arg2: optional; der Teil, der aus einer Zelle bzw einem Element von Arg1 zurückgegeben oder gelöscht (<0) wdn soll; das Argument kann auch ein Zellbereich oder ein Datenfeld sein, das ganze Zahlen enthält. Alternativ hierzu können die auszuwählenden Textteile auch aufgezählt wdn. Das Aufzählungszeichen wird dann automatisch ermittelt. Ein Minus als Löschsymbol darf nur als 1.Zeichen stehen bzw hat nur beim ersten Element eines Datenfeldes Wirkung. Es ist nur entweder Löschen oder Sammeln möglich, nicht beides! Wenn das Argument nicht angegeben wird, wird 1 angenommen. Bei Angabe von 0 bleibt Arg1 unverändert.
Arg3: optional; Zeichen bzw Zeichenkombination, an der der Text lt Arg1 getrennt wdn soll. Bei Nichtangabe wird 1 Leerzeichen angenommen.
Arg4: optional; fehlendes Argument wird als WAHR angenommen; das Argument muss mit Arg1 harmonieren, d.h., ist Arg1 ein Bereich bzw Datenfeld, darf Arg4 entweder nur ein Einzelwert oder ebenfalls ein Bereich/Feld gleicher Elementezahl sein. Anderenfalls darf Arg4 auch nur ein Einzelwert sein.
Sämtliche als Argumente übergebenen Datenfelder und Zellbereiche dürfen nur Vektoren, keine Matrizen sein!
Um die Funktion möglichst universell zu halten, sind hier (in Arg4) die speziellen Bedingg der AfgStellung nicht eingeflossen, d.h., diese müssen extern ausgewertet wdn. Wie, zeigt das anschließende Anwendungsbsp…
=PickOn(A1;-2;";";LINKS(A1)="$")
Die udF sollte auch bei Aufruf durch eine Subroutine fktionieren.
Ich kann nur hoffen, dass sich kein Fehler eingeschlichen hat, denn ich habe das direkt ins Forumsformular geschrieben und nicht getestet…
Gruß+schöSo, Luc :-?