In einer Zelle Daten untereinander auflisten

Question

Hallo Experten,

Ich habe folgende "Herausforderung":

In einem Tabellenblatt "Fertigung 1" können in Spalte N jeweils mehrere Daten pro Zelle enthalten sein, welche mit einem Komma getrennt sind (z.B. "wird bereitgestellt, keine AfA").

Mein Makro soll falls in Spalte N (Range(„N5:N1000“) ein Wert steht, in einem anderen Tabellenblatt „Prämisse“, jeweils eine neue Spalte einfügen und den Inhalt der Spalte N übernehmen.

Das habe ich soweit auch hinbekommen. Hier das Makro dazu:

Sub Makro_Prämisse()

Dim rZeile As Range
Dim rPrämisse As Range

Set rZeile = Worksheets("Fertigung 1").Range("N4:N1000")

For Each rPrämisse In rZeile.Cells

If rPrämisse.Value > "" Then

With Sheets("Prämissen")

.Cells(1, 1).EntireRow.Insert
.Range("A1") = Worksheets("Fertigung 1").Cells(rPrämisse.Row, 14)

End With

End If

Next rPrämisse

End Sub

Ich möchte nun umsetzen, dass wenn in Spalte N („Fertigung 1“) mehrere Daten, die jeweils mit einem Komma getrennt sind, in die neu eingefügte Zelle mit einem Zeilenumbruch untereinander in die gleiche Zelle geschrieben werden (evtl. mit & vbLf & ?).
Beispiel:

Zelle N5 Tabellenblatt „Fertigung 1“ Inhalt = “wird bereitgestellt, keine Afa, Vorrichtung vorhanden“

Zelle A1 Tabellenblatt „Prämisse“ soll es dann aber so dargestellt werden:
"- wird bereitgestellt
- keine AfA
- Vorrichtung vorhanden"

Wie müsste ich mein Makro ändern damit dies möglich ist? Ist das überhaupt realisierbar?
Danke im Voraus!

Mfg peyd

Answer 1

Hallo peyd,

ich würde das mit Split und Join lösen.

Probier mal die folgende Version deines Makros:

Sub Makro_Prämisse()

Dim rZeile As Range
Dim rPrämisse As Range
Dim sText As String
Dim vX As Variant
Dim i As Long

Set rZeile = Worksheets("Fertigung 1").Range("N4:N1000")

For Each rPrämisse In rZeile.Cells

If rPrämisse.Value > "" Then

With Sheets("Prämissen")

.Cells(1, 1).EntireRow.Insert
sText = Worksheets("Fertigung 1").Cells(rPrämisse.Row, 14)

vX = Split(sText, ",")

If UBound(vX) > 0 Then

For i = 0 To UBound(vX)

If i = 0 Then
vX(i) = "- " & vX(i)
Else
vX(i) = "-" & vX(i)
End If

Next i

sText = Join(vX, vbLf)

End If

.Range("A1") = sText

End With

End If

Next rPrämisse

End Sub

Gruß
M.O.

Answer 2

Hallo M.O.,

wow, super schnelle Antwort und wie immer ein genialer Ansatz von dir ;-) Genau so meinte ich das! Vielen vielen Dank!

Könnstest du mir evtl. noch einen Tipp geben, wie ich vor die Daten, wo in den Zellen kein Komma steht, also nur ein Datensatz eingefügt wird, auch ein "- " bekomme?

Mfg peyd

Answer 3

Hallo peyd,

da musst du nur die

If UBound(vX) > 0 Then

Abfrage entfernen:

Sub Makro_Prämisse()

Dim rZeile As Range
Dim rPrämisse As Range
Dim sText As String
Dim vX As Variant
Dim i As Long

Set rZeile = Worksheets("Fertigung 1").Range("N4:N1000")

For Each rPrämisse In rZeile.Cells

If rPrämisse.Value > "" Then

With Sheets("Prämissen")

.Cells(1, 1).EntireRow.Insert
sText = Worksheets("Fertigung 1").Cells(rPrämisse.Row, 14)

vX = Split(sText, ",")

For i = 0 To UBound(vX)

If i = 0 Then
vX(i) = "- " & vX(i)
Else
vX(i) = "-" & vX(i)

End If

Next i

sText = Join(vX, vbLf)

.Range("A1") = sText

End With

End If

Next rPrämisse

End Sub

Gruß

M.O.

Answer 4

Hallo M.O.,

genial! nochmals vielen Dank ;-)

Mfg peyd

Answer 5

Hallo Peyd,

gern geschehen :-).

Gruß

M.O.