Untereinander stehende Zellen in einer Zelle Zusammenfügen

Hallo Slawomir,

wenn deine Daten in Tabelle1 sind, bringt dir das folgende Makro die Daten im gewünschten Format nach Tabelle2. Sonst im Code die Blattnamen anpassen:

Sub Umformen()

Dim varData As Variant, varArt() As Variant, varPreis() As Variant

Dim varDat() As Variant, varAb() As Variant, varTmp As Variant

Dim LRow As Long, n As Long, i As Long

Dim c As Range, dest As Range

Dim FirstAddress As String

Dim myDic As Object
Set myDic = CreateObject("Scripting.Dictionary")

With Sheets("Tabelle1")

   LRow = .Cells(.Rows.Count, "A").End(xlUp).Row

   varData = .Range("A2:E" & LRow)

   For n = LBound(varData) To UBound(varData)

      myDic(varData(n, 1)) = varData(n, 1)

   Next

   varTmp = myDic.items

   Sheets("Tabelle2").Cells(Rows.Count, "A").End(xlUp)(2) _

      .Resize(UBound(varTmp) + 1) = Application.Transpose(varTmp)

      

   For n = LBound(varTmp) To UBound(varTmp)

      i = 0

      Set c = .Range("A:A").Find(varTmp(n), LookIn:=xlValues)

      If Not c Is Nothing Then

         FirstAddress = c.Address

         Do

            ReDim Preserve varArt(i): varArt(i) = c.Offset(, 1)

            ReDim Preserve varPreis(i): varPreis(i) = c.Offset(, 2)

            ReDim Preserve varDat(i): varDat(i) = c.Offset(, 3)

            ReDim Preserve varAb(i): varAb(i) = c.Offset(, 4)

            i = i + 1

            Set c = .Range("A:A").FindNext(c)

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

      End If

      Set dest = Sheets("Tabelle2").Cells(.Rows.Count, "B").End(xlUp)(2)

      dest = Join(varArt, "(*)")

      dest.Offset(, 1) = Join(varPreis, "(*)")

      dest.Offset(, 2) = Join(varDat, "(*)")

      dest.Offset(, 3) = Join(varAb, "(*)")

   Next

End With

Sheets("Tabelle2").Columns("A:E").AutoFit

End Sub

Claus

Hallo Wolfgang,

ich würde die Makroversion vorziehen, aber ich wollte unbedingt herausfinden, ob es auch mit Formel geht.

Probiere mal in A1:

=WENN(UND(A1="";A2<>"");TEXTVERKETTEN(ZEICHEN(10);1;BEREICH.VERSCHIEBEN(A2;;;MIN(WENN(A2:A1000="";ZEILE($2:$1000)))-2));"")

und schließe die Eingabe mit STRG+Shift+Enter ab, da Array-Formel.

Ziehe dann herunter und formatiere die Spalte über Zellen formatieren => Ausrichtung => Zeilenumbruch.

Claus

Hallo Wolfgang,

probiere es mal so:

Sub Zusammenfassen()

Dim LRow As Long, i As Long, n As Long

Dim varData() As Variant, varTmp As Variant

Dim myStr As String

Dim rngC As RangeWith ActiveSheet

    LRow = .Cells(.Rows.Count, 1).End(xlUp).Row

    ReDim Preserve varData(LRow - 2)

    For i = 2 To LRow

        varData(i - 2) = .Cells(i, 1)

    Next

    myStr = Join(varData, Chr(10))

    Do

        myStr = Replace(myStr, Application.Rept(Chr(10), 3), _

            Application.Rept(Chr(10), 2))

    Loop While InStr(myStr, Application.Rept(Chr(10), 3)) > 0

    varTmp = Split(myStr, Application.Rept(Chr(10), 2))

    For Each rngC In .Range("A1:A" & LRow)

        If Len(rngC) = 0 And Len(rngC.Offset(1, 0)) > 0 Then

            rngC.Offset(, 1) = varTmp(n)

            n = n + 1

        End If

    Next

End With

End Sub

Claus

Hallo Wolfgang,

mache diesen Vorgang besser mit VBA. Drücke Alt+F11 => Einfügen Modul und fügen dort diesen Code ein:

Sub Zusammenfassen()

Dim LRow As Long, i As Long, n As Long

Dim varData() As Variant, varTmp As Variant

Dim myStr As String

Dim rngC As Range

With ActiveSheet

    LRow = .Cells(.Rows.Count, 1).End(xlUp).Row

    ReDim Preserve varData(LRow - 2)

    For i = 2 To LRow

        varData(i - 2) = .Cells(i, 1)

    Next

    myStr = Join(varData, Chr(10))

    varTmp = Split(myStr, Chr(10) & Chr(10))

    For Each rngC In .Range("A1:A" & LRow)

        If Len(rngC) = 0 Then

            rngC.Offset(, 1) = varTmp(n)

            n = n + 1

        End If

    Next

End With

End Sub

Gehe zurück auf dein Tabellenblatt und rufe das Makro auf.

Claus

Hallo Claus,

dein Makro funktioniert ausgezeichnet, vielen herzlichen Dank dafür! Danke vor allem auch für die rasche Antwort!

Ich selbst hatte leider mein Ausgangsproblem nicht hundertprozentig so beschrieben, wie es sich mir darstellt. In meiner Tabelle kommt es vor, dass auch mehrere Leerzeilen zwischen zwei Blöcken stehen, die in der Spalte B zusammengefasst werden sollen.

Dein Makro ist nun davon abhängig, dass sich immer genau eine Trennzeile zwischen zwei von den Blöcken befindet, damit es auch in meinem Fall anwendbar ist. Wenn man es ausführt, kommt folgendes heraus:







Das gewünschte Ergebnis wäre folgendes:







Könntest du mir vielleicht nochmals aushelfen, bitte? Ich selbst verstehe leider nichts von VBA und Makros Programmieren.

Viele Grüße,

Wolfgang