Freigeben über

Sverweis Plus mit aus gabe mehrerer Werte in einer Zelle

Anonym
2016-01-13T08:01:23+00:00

Hallo zusammen,

ich brauche eine Formel / VBA Funktion die genau wie der Sverweis funktioniert - nur dass mehrere Werte zurück gegeben werden.

Beispiel mit dem Bespielsprozedurnamen: =SVERWEISPlus(H2;$A$2:$B$7;2;0;"#")

SVERWEIS(Suchkriterium;Suchmatrix;Rückgabespalte;Suchreinfolge;Separator)

Die Suchreihenfolge brauch ich nicht wirklich habe ich nur angegeben da es beim sverweis vorkommt.

Bespiel:

Mein SverweisPlus käme in Spalte F vor:

A B C D E F
KundenNR Material KundenNr Nachnamen Material
1 A 1 Bauer A#B
1 B 2 Marx C#A
2 C 3 Mustemann A
3 A
2 A

Sollte es möglich sein ohne VBA auszukommen wäre es besser - aber nicht zwingend.

Vielen Dank im Voraus.

Matthias

Microsoft 365 und Office | Excel | Für Zuhause | Windows

Gesperrte Frage. Diese Frage wurde aus der Microsoft-Support-Community migriert. Sie können darüber abstimmen, ob sie hilfreich ist, aber Sie können keine Kommentare oder Antworten hinzufügen oder der Frage folgen.

0 Kommentare
Antwort, die vom Frageautor angenommen wurde
  1. Andreas Killer 144.1K Zuverlässigkeitspunkte Freiwilliger Moderator
    2016-01-15T13:49:51+00:00

    Mein Funktionsaufruf ist:

    sverweisplus(vSuchen As Variant, vArea As Range, vSpalte As Long, Optional vSeparator As Variant)

    Dann schreib Dir eine UDF und rufe Sie als Formel auf:

    =sverweisplus(D2;A:B;2;"#")

    Andreas.

    Option Explicit

    Function sverweisplus(vSuchen As Variant, vArea As Range, vSpalte As Long, _

        Optional vSeparator As Variant)

      Dim All As Range, R As Range

      Set All = FindAll(vArea.Columns(1), vSuchen, SearchFormat:=True)

      If All Is Nothing Then

        sverweisplus = CVErr(xlErrNA)

      Else

        For Each R In All

          Set R = Intersect(vArea.Columns(vSpalte), R.EntireRow)

          sverweisplus = sverweisplus & R.Value & vSeparator

        Next

        sverweisplus = Left(sverweisplus, Len(sverweisplus) - Len(vSeparator))

      End If

    End Function

    Function FindAll(ByVal Where As Range, ByVal What, _

        Optional ByVal After As Variant, _

        Optional ByVal LookIn As XlFindLookIn = xlValues, _

        Optional ByVal LookAt As XlLookAt = xlWhole, _

        Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _

        Optional ByVal SearchDirection As XlSearchDirection = xlNext, _

        Optional ByVal MatchCase As Boolean = False, _

        Optional ByVal SearchFormat As Boolean = False) As Range

      'Find all occurrences of What in Where (Windows version)

      Dim FirstAddress As String

      Dim C As Range

      'From FastUnion:

      Dim Stack As New Collection

      Dim Temp() As Range, Item

      Dim i As Long, j As Long

      If Where Is Nothing Then Exit Function

      If SearchDirection = xlNext And IsMissing(After) Then

        'Set After to the last cell in Where to return the first cell in Where in front if _

          it match What

        Set C = Where.Areas(Where.Areas.Count)

        'BUG in XL2010: Cells.Count produces a RTE 6 if C is the whole sheet

        'Set After = C.Cells(C.Cells.Count)

        Set After = C.Cells(C.Rows.Count * CDec(C.Columns.Count))

      End If

      Set C = Where.Find(What, After, LookIn, LookAt, SearchOrder, _

        SearchDirection, MatchCase, SearchFormat:=SearchFormat)

      If C Is Nothing Then Exit Function

      FirstAddress = C.Address

      Do

        Stack.Add C

        If SearchFormat Then

          'If you call this function from an UDF and _

            you find only the first cell use this instead

          Set C = Where.Find(What, C, LookIn, LookAt, SearchOrder, _

            SearchDirection, MatchCase, SearchFormat:=SearchFormat)

        Else

          If SearchDirection = xlNext Then

            Set C = Where.FindNext(C)

          Else

            Set C = Where.FindPrevious(C)

          End If

        End If

        'Can happen if we have merged cells

        If C Is Nothing Then Exit Do

      Loop Until FirstAddress = C.Address

      'FastUnion algorithm © Andreas Killer, 2011:

      'Get all cells as fragments

      ReDim Temp(0 To Stack.Count - 1)

      i = 0

      For Each Item In Stack

        Set Temp(i) = Item

        i = i + 1

      Next

      'Combine each fragment with the next one

      j = 1

      Do

        For i = 0 To UBound(Temp) - j Step j * 2

          Set Temp(i) = Union(Temp(i), Temp(i + j))

        Next

        j = j * 2

      Loop Until j > UBound(Temp)

      'At this point we have all cells in the first fragment

      Set FindAll = Temp(0)

    End Function

    Eine Person fand diese Antwort hilfreich.
    0 Kommentare

6 zusätzliche Antworten

Sortieren nach: Am hilfreichsten
Am hilfreichsten Neueste Älteste
  1. Andreas Killer 144.1K Zuverlässigkeitspunkte Freiwilliger Moderator
    2016-02-02T16:10:30+00:00

    Also wäre der Rückgabewert A#C#D#A - das "A" nur ein Mal vorkommt: A#C#D 

    und wenn wir dabei sind - vielleicht auch sortiert?

    Hallo Matthias,

    aber klar, gerade wenn das sortiert ist wird es sogar einfacher.

    Die Function sverweisplus tauscht Du bitte aus und die Sub InsertionSort_Prim kommt hinzu.

    Andreas.

    Function sverweisplus(vSuchen As Variant, vArea As Range, vSpalte As Long, _

        Optional vSeparator As Variant)

      Dim All As Range, R As Range

      Dim Data

      Dim i As Long, k As Long

      Set All = FindAll(vArea.Columns(1), vSuchen, SearchFormat:=True)

      If All Is Nothing Then

        sverweisplus = CVErr(xlErrNA)

      Else

        'Leeres Array erzeugen => Data(0 to -1)

        Data = Array()

        For Each R In All

          Set R = Intersect(vArea.Columns(vSpalte), R.EntireRow)

          'Um eins größer machen

          ReDim Preserve Data(0 To UBound(Data) + 1)

          'Am Ende den Wert speichern

          Data(UBound(Data)) = R.Value

        Next

        'Sortieren

        InsertionSort_Prim Data

        'Doppelte Werte entfernen

        For i = 1 To UBound(Data)

          If Data(i) <> Data(i - 1) Then

            k = k + 1

            If i > k Then Data(k) = Data(i)

          End If

        Next

        ReDim Preserve Data(0 To k)

        'Als String zurückgeben

        sverweisplus = Join(Data, vSeparator)

      End If

    End Function

    Sub InsertionSort_Prim(ByRef Liste)

      Dim i As Long, j As Long, Temp

      For i = LBound(Liste) + 1 To UBound(Liste)

        Temp = Liste(i)

        For j = i - 1 To LBound(Liste) Step -1

          If Liste(j) <= Temp Then Exit For

          Liste(j + 1) = Liste(j)

        Next

        Liste(j + 1) = Temp

      Next

    End Sub

    Eine Person fand diese Antwort hilfreich.
    0 Kommentare
  2. Anonym
    2016-01-18T14:03:10+00:00

    Hallo zusammen,

    ja klasse - genau das!

    Die Funktion(en) machen genau, dass was ich suchte.

    Und ich kannte die Funktionen auch nicht - somit lerne ich noch was dazu.

    Vielen Dank für die Hilfe - Thema ist gelöst.

    Viele Grüße

    Matthias

    0 Kommentare
  3. Anonym
    2016-01-15T12:16:07+00:00

    Hallo Claus,

    mit der Find-Methode funktioniert es schon etwas.

    Ich möchte mein Problem noch etwas konkretisieren:

    Mein Funktionsaufruf ist:

    sverweisplus(vSuchen As Variant, vArea As Range, vSpalte As Long, Optional vSeparator As Variant)

    mit Find werden die Einträge die ich Suche gefunden.

    Nur möchte ich genau in dieser Zeile die Spalte des Wertes "vSpalte" finden.

    Der Wert in der vSplate - soll dann in den STRING der nach her zur Rückgabe dient.

    Also ich benötige jetzt erst mal - das Methode FIND mit den Wert aus Spalte "X" zurück gibt.

    Danke

    Matthias

    0 Kommentare
  4. Anonym
    2016-01-13T11:15:45+00:00

    Hallo Matthias,

    probiere es mal so (Bereiche noch anpassen):

    Sub Uebertrag()

    Dim varOut() As Variant

    Dim c As Range, Bereich As Range, rngC As Range

    Dim firstAddress As String

    Dim n As Long

    Set Bereich = Range("A1:A100")

    For Each rngC In Range("D2:D5")

        n = 0

        Set c = Bereich.Find(rngC.Value, LookIn:=xlValues)

        If Not c Is Nothing Then

            firstAddress = c.Address

            Do

                ReDim Preserve varOut(n)

                varOut(n) = c.Offset(, 1)

                n = n + 1

                Set c = Bereich.FindNext(c)

            Loop While Not c Is Nothing And c.Address <> firstAddress

        End If

        rngC.Offset(, 2) = IIf(UBound(varOut) > 0, Join(varOut, "#"), varOut(0))

        Erase varOut

    Next

    End Sub

    Claus

    0 Kommentare