Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1364to1368
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Verketten anhand von Kriterien

Verketten anhand von Kriterien
20.06.2014 16:45:02
KP

Hallo zusammen
Ich benutze Folgendes um mehrere Zellen in einer Zelle zusammenzufügen und mit einem Komma zu trennen:


Function Verketten2(ByRef bereich As Range, Trennzeichen As String) As String
Dim rng As Range
For Each rng In bereich
If rng <> "" Then
Verketten2 = Verketten2 & rng & Trennzeichen
End If
Next
If Len(Verketten2) > 0 Then _
Verketten2 = Left(Verketten2, Len(Verketten2) - Len(Trennzeichen))
End Function

Im Excelsheet füge ich dann in die entsprechende Zelle z.B. =Verketten2(K2:K14;", ")
Dabei tue ich den zu wählenden Bereich (K2:K14 etc.) händisch eintragen/wählen.
Wie könnte man das Makro erweitern, damit die Funktion den Bereich anhand von gewissen Kriterien automatisch wählt? Z.B. wenn in Zellen A2:A14 die Zahl 1 steht dann verkette mir die Zellen K2:K14, resp. verkette die Zellen in Spalte K bei denen in Spalte A eine gewisse Zahl (1,2,3,4 etc.) drin steht?
Für Ideen wäre ich sehr dankbar.
Beste Grüsse
KP

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Damit würdest du eine halbwegs universelle ...
20.06.2014 19:27:24
Luc:-?
…UDF zu einer sog Insellösung degradieren, die nur unter ganz spezifischen Bedingungen arbeitet, KP,
also eine „Eintagsfliege züchten“. Das ist nicht der Sinn einer UDF wie ich ihn verstehe und vertrete! Deshalb mal hier etwas Universelles, dem du auch gewisse Kriterien mitgeben kannst:

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.
'   Vs1.0 -LSr -cd: 20140620-17:00 -1pub: herber 20140620 -lupd: 20140620-19:00
Function MxJoin(ByVal Bezug, Optional ByVal Trennzeichen = " ", Optional ByVal Auswahl As Long)
Dim isCol As Boolean, aw As Long, bez As Variant, _
ber As Range, Bereich As Range, wf As WorksheetFunction
On Error GoTo fx
isCol = Auswahl > 0: aw = Abs(Auswahl): Set wf = WorksheetFunction
If TypeName(Bezug) = "Range" Then
Set Bereich = Bezug
If aw = 0 Or (Bereich.Areas.Count = 1 And CBool(aw)) Then
If isCol Then
For Each ber In Bereich.Columns(aw).Cells
If ber <> "" Then MxJoin = MxJoin & Trennzeichen & ber
Next ber
ElseIf Auswahl = 0 Then
For Each ber In Bereich
If ber <> "" Then MxJoin = MxJoin & Trennzeichen & ber
Next ber
Else
For Each ber In Bereich.Rows(aw).Cells
If ber <> "" Then MxJoin = MxJoin & Trennzeichen & ber
Next ber
End If
Else: If Not isCol Then aw = Bereich.Areas.Count + Auswahl
For Each ber In Bereich.Areas(aw)
If ber <> "" Then MxJoin = MxJoin & Trennzeichen & ber
Next ber
End If
MxJoin = Mid(MxJoin, 2)
ElseIf Auswahl = 0 Then
For Each bez In Bezug
If bez <> "" Then MxJoin = MxJoin & Trennzeichen & bez
Next bez
MxJoin = Mid(MxJoin, 2)
Else: On Error Resume Next: If IsError(UBound(Bezug, 2)) Then _
ReDim Preserve Bezug(LBound(Bezug) To UBound(Bezug), _
LBound(Bezug) To LBound(Bezug))
On Error GoTo fx
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
MxJoin = Join(wf.Transpose(wf.Index(Bezug, 0, aw)), Trennzeichen)
Else
If aw < LBound(Bezug, 1) Then
aw = LBound(Bezug, 1)
ElseIf aw > UBound(Bezug, 1) Then
aw = UBound(Bezug, 1)
End If
MxJoin = Join(wf.Index(Bezug, aw, 0), Trennzeichen)
End If
End If
fx: If CBool(Err.Number) Then MxJoin = CVErr(Err.Number)
Set Bereich = Nothing: Set wf = Nothing
End Function
Sie kann dann bspw wie folgt in ZellFmln eingesetzt wdn:
Anzeige
Nachtrag: Deinen 2.Fall kann man, bezogen ...
20.06.2014 21:10:31
Luc:-?
…auf mein Bsp, im Prinzip mit folgd MatrixFml lösen, KP;
a m ⇐ {=MxJoin(WENN(C1:C5="x";A1:A5;""))} bzw
a m b n ⇐ {=MxJoin(WENN(C1:C5="x";A1:B5;""))} oder auch
a b m n ⇐ {=MxJoin(MTRANS(WENN(C1:C5="x";A1:B5;"")))}
Luc :-?

AW: Nachtrag: Deinen 2.Fall kann man, bezogen ...
21.06.2014 17:48:13
Karol Prikopsky
Hallo Luc
Einen schönen Dank für den Code. Damit lässt sich Einiges machen. Allerdings bringt Dein Beispiel
a m ⇐ {=MxJoin(WENN(C1:C5="x";A1:A5;""))}
bei mir nicht das Resultat "a m" sondern, "a d g j m", also er zählt den ganzen Bereich A1:A5.
Was mache ich falsch?
Danke schön und Grüsse
KP

Anzeige
Wenn du meine BspTab genau kopiert hast, ...
21.06.2014 18:15:57
Luc:-?
…Karol,
sollte auch mein Ergebnis rauskommen. So sehe ich nicht, was du falsch gemacht haben könntest.
Aber verwende besser die neue Version1.1; die bietet noch mehr Möglichkeiten und fktt auch richtiger!
Gruß + schöWE, Luc :-?

AW: Wenn du meine BspTab genau kopiert hast, ...
21.06.2014 20:02:44
Karol Prikopsky
Hallo Luc
Danke sehr, habe die neue, wie die alte Version ausprobiert. Leider komme ich nicht zu Deinem Resultat. Die Tabelle ist identisch und der Code auch (siehe Bild)
Userbild
Ich bin am verzweifeln, da mir dies sehr helfen und Zeit ersparen würde, aber es funktioniert bei mir nicht. Kann es an der Excel Version liegen? Momentan arbeite ich mit der MS Office 2013 Version.
Danke Dir sehr,
Karol

Anzeige
Du musst die Fml als MatrixFormel eingeben, ...
21.06.2014 21:37:47
Luc:-?
…Karol,
damit die WENN-Fml in Arg1 das Auswahl-Datenfeld erzeugt und auch in Gänze zurückgibt!
MatrixFormel ist xlHilfe-Stichwort; Eingabe mit Tasten [Strg][Enter] abschließen, nicht nur mit [Enter]. Dann wdn auch die {} erzeugt!
Luc :-?

AW: Du musst die Fml als MatrixFormel eingeben, ...
21.06.2014 22:00:21
Karol Prikopsky
Vielen herzlichen Dank Luc und Entschuldigung für die Umstände - da habe ich wieder was gelernt. Es funktioniert perfekt...
Beste Grüsse und nochmals danke
Karol

Ja, bitte sehr, aber nimm die neue Vs1.1! Gruß owT
22.06.2014 02:24:15
Luc:-?
:-?

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 :-?

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige