Hallo Nicole! Die Beschreibung hat ein paar Fragen aufgeworfen. Die Umbrüche sind in Spalte A und B (bei dir Zeile 1 und 2). Da ich bei dem Beispiel nicht ganz klar kommen. Du hast also in
Zeile 1 in der Zelle A1 einen Eintrag mit 2 Zeilen und in B1 mit 3 Zeilen,
in Zeile 2 in A2 einen Eintrag mit 2 Zeilen, B2 mit einem Eintrag
usw. .
Das Programm soll dann alle INhalt auf die darunterliegen Werte aufteilen. Ist die Reihenfolg dabei egal oder sollen die ursp. Einträge aus Spalte A und B in der selben Zeile beginnen. Das würde mit meinem Beispiel dann so sein:
von Zeile 1 bis 3 sind dann die Werte aus der alten Zeile 1 , wobei A3 leer ist, da A1 nr 2 zeilig war.
Ab Zeile 4 kommen dann die Werte aus der alten Zeile 2 (wobei hier dann B5 leer wäre ) usw.
Wenn das so sein soll, geht der Code. Probiere mal bitte ob das so wie gewünscht war.
Option Explicit
Sub aufteilen()
Dim zeil1 As Long 'Anzahlen Zeilen in Spalte A
Dim zeil2 As Long 'Anzahlen Zeilen in Spalte B
Dim anzahl As Long ' Zeilen je Zelle von Spalte A
Dim anzahl2 As Long ' Zeile je Zelle von Spalte B
Dim a As Long ' zum Zählen
Dim b As Long ' zum Zählen
Dim zellzeil1 ' Zellinhalte der Zellen von Spalte A
Dim zellzeil2 ' Zellinhalte der Zellen von Spalte B
Application.ScreenUpdating = False
'Einträge in Spalte A und B suchen
zeil1 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
zeil2 = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
'größten Wert suchen
If zeil1 < zeil2 Then
anzahl = zeil2
Else
anzahl = zeil1
End If
'durch alle Zeilen durchgehen
For a = anzahl To 1 Step -1
'Inhalt der gerade aktuellen Zelle such und nach "Zeilenumbruch" aufsplitten
zellzeil1 = Split(ActiveSheet.Cells(a, 1), vbLf)
zellzeil2 = Split(ActiveSheet.Cells(a, 2), vbLf)
'prüfen Welche Zelle (aus Spalte A oder B) mehr Umbrüche hatte
If UBound(zellzeil1) < UBound(zellzeil2) Then
anzahl2 = UBound(zellzeil2)
Else
anzahl2 = UBound(zellzeil1)
End If
'je Umbruch Zeile einfügen und den jeweiligen Textteil eintragen
For b = anzahl2 - 1 To 0 Step -1
ActiveSheet.Cells(a + 1, 1).EntireRow.Insert Shift:=xlUp
If UBound(zellzeil1) >= b + 1 Then Cells(a + 1, 1) = zellzeil1(b + 1)
If UBound(zellzeil2) >= b + 1 Then Cells(a + 1, 2) = zellzeil2(b + 1)
Next b
'jetzt Ausgangszelle mit erstem Teil vom Inhalt beschreiben
If UBound(zellzeil1) >= 0 Then Cells(a, 1) = zellzeil1(0)
If UBound(zellzeil2) >= 0 Then Cells(a, 2) = zellzeil2(0)
Next a
Application.ScreenUpdating = True
End Sub
|