Neue, universellere Version!
21.06.2014 18:09:34
Luc:-?
Hello, again!
Habe noch eine Vergesslichkeit korrigiert (fette +1 und ebenso 3, besser schon in Vs1.0 vorhandene Zeilen in der neuen Version hinzugefügt. Die Entsprechung des neu gefassten roten PgmTeils in der alten Vs dürfte nicht wie gewünscht fktn, auch deshalb die neue Vs1.1. Auch wollte ich ursprüngl gleich mehrere Trennzeichen (als Vektor) für die verschiedenen Verbindungsziele zulassen, was ich nunmehr nachgeholt habe…
Rem Fkt verbindet alle Werte eines (Teil-)Bezugs lt Arg1 über Arg2 miteinander;
' m.Arg3 kn 1 Auswahl getroffen wdn - Area b.unzushgd Bereichen, sonst Zl/Sp;
' Arg2 kn als Vektor (Zeile/Spalte) m.je 1 Trennz pro mögl Arg3 anggeben wdn.
' Vs1.1 -LSr -cd:20140620-17:00 -1pub:herber 20140620/21 -lupd:20140621-16:30
Function MxJoin(ByVal Bezug, Optional ByVal Trennzeichen, Optional ByVal Auswahl As Long)
Const defTrZ$ = " " 'Anm: Hier auch and StanddTrennz eintragbar!
Dim isCol As Boolean, isTzArr As Boolean, aw As Long, na As Long, tz As String, _
bez As Variant, ber As Range, Bereich As Range, wf As WorksheetFunction
On Error GoTo fx: Set wf = WorksheetFunction
If IsError(Bezug) Then Err.Raise xlErrRef
If IsMissing(Trennzeichen) Then Trennzeichen = defTrZ
isCol = Auswahl > 0: isTzArr = IsArray(Trennzeichen): aw = Abs(Auswahl)
If isTzArr Then
If TypeName(Trennzeichen) = "Range" Then _
Trennzeichen = wf.Transpose(Trennzeichen)
On Error Resume Next
If IsError(LBound(Trennzeichen, 2)) Then
Else: Trennzeichen = wf.Transpose(Trennzeichen)
If IsError(LBound(Trennzeichen, 2)) Then Else _
On Error GoTo fx: Err.Raise xlErrNA
End If
On Error GoTo fx: na = 1 - LBound(Trennzeichen)
End If
If TypeName(Bezug) = "Range" Then
Set Bereich = Bezug
If aw = 0 Or (Bereich.Areas.Count = 1 And CBool(aw)) Then
If isCol Then
aw = wf.Min(aw, Bereich.Columns.Count): GoSub tf
For Each ber In Bereich.Columns(aw).Cells
If ber <> "" Then MxJoin = MxJoin & tz & ber
Next ber
ElseIf Auswahl = 0 Then
If isTzArr Then tz = Trennzeichen(1 - na) Else tz = Trennzeichen
For Each ber In Bereich
If ber <> "" Then MxJoin = MxJoin & tz & ber
Next ber
Else: aw = wf.Min(aw, Bereich.Rows.Count): GoSub tf
For Each ber In Bereich.Rows(aw).Cells
If ber <> "" Then MxJoin = MxJoin & tz & ber
Next ber
End If
Else: If Not isCol Then aw=Bereich.Areas.Count+1+Auswahl
aw=wf.Min(wf.Max(aw,1),Bereich.Areas.Count):GoSub tf
For Each ber In Bereich.Areas(aw)
If ber <> "" Then MxJoin = MxJoin & tz & ber
Next ber
End If
MxJoin = Mid(MxJoin, 2)
ElseIf Auswahl = 0 Then
If isTzArr Then tz = Trennzeichen(1 - na) Else tz = Trennzeichen
For Each bez In Bezug
If bez <> "" Then MxJoin = MxJoin & tz & bez
Next bez
MxJoin = Mid(MxJoin, 2)
Else: On Error Resume Next
If IsError(UBound(Bezug, 2)) Then
On Error GoTo fx: Bezug = wf.Transpose(Bezug): isCol = Not isCol
Else: On Error GoTo fx
End If
If isCol Then
If aw < LBound(Bezug, 2) Then
aw = LBound(Bezug, 2)
ElseIf aw > UBound(Bezug, 2) Then
aw = UBound(Bezug, 2)
End If
GoSub tf: Bezug = wf.Index(Bezug, 0, aw)
If wf.CountA(Bezug) > 1 Then MxJoin = Join(wf.Transpose(Bezug), tz)
Else
If aw < LBound(Bezug, 1) Then
aw = LBound(Bezug, 1)
ElseIf aw > UBound(Bezug, 1) Then
aw = UBound(Bezug, 1)
End If
GoSub tf: Bezug = wf.Index(Bezug, aw, 0)
If wf.CountA(Bezug) > 1 Then MxJoin = Join(Bezug, tz)
End If
If IsEmpty(MxJoin) Then MxJoin = wf.Index(Bezug, 1, 1)
End If
GoTo ex
Rem -- tzUP --
tf: If isTzArr Then
isTzArr = aw <= UBound(Trennzeichen) + na
If isTzArr Then tz = Trennzeichen(aw - na) Else tz = defTrZ
Else: tz = Trennzeichen
End If
Return
Rem F-Bhdl
fx: MxJoin = IIf(Err.Number < xlErrNull Or _
Err.Number > xlErrNA, CVErr(xlErrNull), CVErr(Err.Number))
ex: Set Bereich = Nothing: Set wf = Nothing
End Function
Damit fktn dann auch die folgd Fmln (wieder bezogen auf mein Bsp):
b e h k n ⇐ =MxJoin(($A$1:$A$5;$B$1:$B$5);;-1)
j\k\y ⇐ =MxJoin(($A$1:$C$1;$A$4:$C$4);{"/"."\"};-1)
a/b/x ⇐ =MxJoin(($A$1:$C$1;$A$4:$C$4);{"/"."\"};1)
#BEZUG! ⇐ =MxJoin(""&($A$1:$C$1;$A$4:$C$4);{"/"."\"};1)
j\k\y ⇐ =MxJoin(($A$1:$C$1;$A$4:$C$4);{"/";"\"};3)
#NV ⇐ =MxJoin(($A$1:$C$1;$A$4:$C$4);{"/"."\";" ".", "};3)
b ⇐ {=MxJoin(""&$A$1:$C$1;{"/"."\"};2)}
Die FehlerBspp belegen, dass ein unzusammenhängender Bereich so nicht in ein Datenfeld umgewandelt wdn kann (#BEZUG!) bzw eine Matrix nicht als Arg2 zugelassen ist (#NV). Beim letzten Ergebnis kann nichts verbunden wdn, weil letztlich nur ein Wert ausgewählt wurde. Leere Zellen bzw LeerStrings entfallen grundsätzlich. Das war auch in Vs1.0 schon so.
Nicht der Realität entsprd Angaben als Arg3 wdn nach oben bzw unten autokorrigiert.
Luc :-?