Mehrere Begriffe in einer Zelle in einzelne Zellen aufteilen.

[bsgVeritas]

Hallo liebes Forum,

mein Problem stellt sich wie folgt da. Ich habe eine größere Excelliste mit mehreren Datensätzen (Zeilen) und Spalten (versch Attribute).

In einigen Datensätzen also Zeilen stehen in einer Spalte mit der Funktion: (ALT+Enter) also mit dem Zeilenumbruch getrennt mehrere Wörter. 

Für jedes Dieser Wörter würde ich gern eine neue Zeile angelegt haben mit den gleichen Einträgen der Attribute wie in der Ursprungszeile wo sie herkommen. Zur veranschlaulischung meines Problems lade ich mal ein Bild und eine Beispieldatei hoch.

Meine konkrete Frage ist jetzt hier kann man dies einfacher hinbekommen als manuelle über Zelle kopierne (in der die Wörter untereinander stehen), dann mit "Text in Spalten" --> bei trennen "Alt Enter 101" angeben. Dann manuell die Ursprungszeile so oft kopieren wie das wort vorkommt und die geänderten Spalten (attribute) ergänzen.?!

Bild:

[url=
Dateiupload bitte im Forum! So geht es: Klick mich!
]
Datei:  


Danke mfg

[coemm]

Hallo liebes Forum,

Datei:  wie kann ich dateien hochladen ? oder muss ich das über einen link machen ?

Danke mfg

Hallo bsg

so

[bsgVeritas]

Ist das mit excel vielleicht so einfach nicht möglich und kommt an vba nicht vorbei ? 

Kann das einer schon sagen ?  Ich versuchs mal mit makro aufzeichnen ..

[WillWissen]

Hi bsg,

hast du Connys Antwort auf deine Frage bzgl. Hochladens einer Datei nicht gelesen?

Das Wort "So" ist farbig und ein anklickbarer Link. Lies dir doch bitte den dahinter stehenden Beitrag durch.

[Storax]

Ist das mit excel vielleicht so einfach nicht möglich und kommt an vba nicht vorbei ? 

Kann das einer schon sagen ?  Ich versuchs mal mit makro aufzeichnen ..

Code:

Option Explicit

Sub AltEnterSplit()

Dim sInp() As String
Dim sTeileNr() As String
Dim sAnz() As String
Dim delLineNo() As Long
Dim rg As Range
Dim cell As Range
Dim rgBezeichnung As Range
Dim wks As Worksheet
Dim i As Integer, j As Integer
Dim newLine As Range
Dim oldLine As Range
Const ListWidth = 17
Const colBez = 8



   On Error GoTo AltEnterSplit_Error

   ' If neceessary adjust codename of worksheet
   Set wks = Tabelle1
   Set rgBezeichnung = wks.Range(wks.Cells(2, colBez), wks.Cells(2, colBez).End(xlDown))
   j = 0
   Application.ScreenUpdating = False


   For Each cell In rgBezeichnung

       sInp = Split(cell.Value, vbLf)

       If LBound(sInp) = UBound(sInp) Then
           ' Do nothing
       Else

           sTeileNr = Split(cell.Offset(0, -1).Value, vbLf)
           sAnz = Split(cell.Offset(0, 1).Value, vbLf)

           ' add as many new lines as entries in the array
           For i = LBound(sInp) To UBound(sInp)
               ' Add single line
               Set rg = Range("A1").End(xlDown).Offset(1, 0)
               Set newLine = wks.Range(rg, wks.Cells(rg.Row, ListWidth))
               Set oldLine = wks.Range(Cells(cell.Row, 1), wks.Cells(cell.Row, ListWidth))
               newLine.Value = oldLine.Value
               newLine.Cells(1, colBez).Value = sInp(i)

               ' If adjacent cells don't have the same number of lines just ignore it
               On Error Resume Next
               newLine.Cells(1, colBez - 1).Value = sTeileNr(i)
               newLine.Cells(1, colBez + 1).Value = sAnz(i)
               On Error GoTo AltEnterSplit_Error
           Next i

           ' Collect the line to delete
           ReDim Preserve delLineNo(j)
           delLineNo(j) = cell.Row
           j = j + 1

       End If

   Next cell

   For i = UBound(delLineNo) To LBound(delLineNo) Step -1
       Rows(delLineNo(i)).Delete
   Next

   On Error GoTo 0
   Exit Sub

AltEnterSplit_Error:

   MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AltEnterSplit of Modul Modul1"

End Sub