Office: (Office 2016) Wenn gleiche Werte in einer Spalte, dann Inhalte aus Zeile in eine neue Spalte schreiben

Hallo zusammen,
ich möchte gerne die Spalte D automatisch generieren lassen basierend auf einer Übereinstimmung in der Spalte C. In Spalte D sollen dann die passenden Werte aus Spalte A komma-separiert aufgeführt werden.

Wie könnte dies funktionieren?
Lieben Dank an die Community :-)

 

Hi,

das kannst du mit folgendem Makro realisieren:

Code:

Sub Zuordnung()
    Dim objDic As Object
    Dim Bereich As Variant
    Dim lngLetzte As Long
    Dim lngZeile As Long
    Dim lngZaehler As Long
    Dim rngZelle As Range
    Dim arrDaten As Variant
    Dim blnFilter As Boolean
    Set objDic = CreateObject("Scripting.Dictionary")
    lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
    Bereich = Range("C2", Range("C2").End(xlDown))
    For lngZeile = LBound(Bereich) To UBound(Bereich)
        objDic(Bereich(lngZeile, 1)) = 0
    Next
    arrDaten = objDic.keys
    For lngZaehler = LBound(arrDaten) To UBound(arrDaten)
        Range("A1").CurrentRegion.AutoFilter field:=3, Criteria1:=arrDaten(lngZaehler)
        For lngZeile = 2 To lngLetzte
            If Cells(lngZeile, 1).EntireRow.Height > 0 Then
                For Each rngZelle In Range("A2:A" & lngLetzte).SpecialCells(xlCellTypeVisible)
                    If rngZelle <> Cells(lngZeile, 1) Then
                        If InStr(Cells(lngZeile, 4), rngZelle) = 0 Then Cells(lngZeile, 4) = Cells(lngZeile, 4) & "," & rngZelle
                    End If
                Next rngZelle
                If Left(Cells(lngZeile, 4), 1) = "," Then Cells(lngZeile, 4) = Mid(Cells(lngZeile, 4), 2)
            End If
        Next lngZeile
    Next lngZaehler
    Range("A1").CurrentRegion.AutoFilter
End Sub

Bis später, Karin

 

Einen ganz lieben Dank!!! Ich muss erstmal genau schauen, wie das überhaupt funktioniert - aber es funktioniert!

 

... und jetzt noch ein Schritt weiter (sorry....) - ist so ein Konstrukt realisierbar?

 

Code:

Sub Zuordnung2()
    Dim objDic As Object
    Dim Bereich As Variant
    Dim lngLetzte As Long
    Dim lngZeile As Long
    Dim lngZaehler As Long
    Dim rngZelle As Range
    Dim arrDaten As Variant
    Dim intSpalte As Integer
    Set objDic = CreateObject("Scripting.Dictionary")
    lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
    Bereich = Range("D4", Range("D4").End(xlDown))
    For lngZeile = LBound(Bereich) To UBound(Bereich)
        objDic(Bereich(lngZeile, 1)) = 0
    Next
    arrDaten = objDic.keys
    For lngZaehler = LBound(arrDaten) To UBound(arrDaten)
        Range("A1").CurrentRegion.AutoFilter field:=4, Criteria1:=arrDaten(lngZaehler)
        For lngZeile = 2 To lngLetzte
            intSpalte = 5
            If Cells(lngZeile, 1).EntireRow.Height > 0 Then
                For Each rngZelle In Range("A2:A" & lngLetzte).SpecialCells(xlCellTypeVisible)
                    If rngZelle <> Cells(lngZeile, 1) Then
                        Cells(lngZeile, intSpalte) = rngZelle
                        Cells(lngZeile, intSpalte + 1) = rngZelle.Offset(0, 1)
                        intSpalte = intSpalte + 2
                    End If
                Next rngZelle
            End If
        Next lngZeile
    Next lngZaehler
    Range("A1").CurrentRegion.AutoFilter field:=4
End Sub

---

 

Wow, das ist ja großartig!!!!!! Einen riiiiiiieeeeesen Dank an dich!!!!!