Split Zellinhalt nach Zeilenumbruch

[Leonhard]

Hallo zusammen, 

ich habe viele Dateien in einem Ordner die im ersten Arbeitsblatt ab Zelle C20 gleich bearbeitet werden müssten. Ab Zelle C20:C(letzte Zeile) müssten die Einträge in einer Zelle die durch (Alt + Return) voneinander „getrennt“ sind aufgeteilt werden. Das Kriterium welches als Trennzeichen fungieren würde wäre also der Zeilenumbruch (Alt + Return) in einer Zelle. Die einzelnen Einträge einer Zelle müsste dann je nach Anzahl der durch den Zeilenumbruch vorhandenen Einträge in die Zellen rechts davon aufgeteilt werden und die dort vorhandenen Bestandswerte verschoben werden. Die Verschiebung der Bestandswerte soll einheitlich geschehen, das wird am Beispiel ersichtlicher als ich es beschreiben könnte.

Habe hierzu schon Codeschnipsel gefunden, allerdings überschreiben die alle die Bestandsdaten, bieten nicht die Möglichkeit das für mehrere Dateien die in einem Ordner sind durchlaufen zu lassen, starten nicht ab C20. Freue mich über eure Hilfe 

Beste Grüße
Leo

Korrektur:
Spalte C kann durchaus auch leere Zellen zwischendurch haben und danach kommen wieder Einträge die nach der Logik bearbeitet werden müssten. Eine feste Range bis C5000 wäre aber völlig ausreichend falls es dafür keine charmantere Lösung gibt 

[LCohen]

Vor D 5 Spalten einfügen
D20: =GLÄTTEN(TEIL(WECHSELN(C20;ZEICHEN(10);WIEDERHOLEN(" ";199));SPALTE(A1:E1)*199-198;199)) frisches Excel
D20[:H20]: =GLÄTTEN(TEIL(WECHSELN($C20;ZEICHEN(10);WIEDERHOLEN(" ";199));SPALTE(A1)*199-198;199)) altes Excel

[Leonhard]

Hi LCohen,

das macht genau das was es soll! Wie gesagt sind es aber recht viele Dateien die ich nacheinander so bearbeiten muss und ich weiß nie wie viele Leerspalten ich einfügen müsste, da die Anzahl der Einträge doch stark variieren kann.

Beste Grüße
Leo

[LCohen]

Dann würde ich 19 (das ist auch eine Primzahl) statt 5 nehmen. Und die anderen Parameter entsprechend anpassen.

[Elex]

Hi

Teste erst mal an Kopien. Den Code aus einer Datei starten die nicht beiarbeitet wird.

Code:

Sub Leo()
Dim j As Long, a As Long, k As Long, rng As Range, Werte, ArrA

On Error GoTo Fehler
Application.ScreenUpdating = False

With Application.FileDialog(msoFileDialogOpen)  'Datei Auswahl Dialog
     .AllowMultiSelect = True   'Mehrfachauswahl
     .Show

   For j = 1 To .SelectedItems.Count    'Datein nacheinander öffnen
       Workbooks.Open (.SelectedItems(j))
        Set rng = Application.Intersect(Sheets(1).UsedRange, Range("D:XFD"))
          Werte = rng.Value
          rng.Clear
          k = 0
          For a = 20 To Cells(Rows.Count, 3).End(xlUp).Row
            If Cells(a, 3).Value <> "" Then
               ArrA = Split(Cells(a, 3), Chr(10))
               Cells(a, 3).Resize(, UBound(ArrA, 1) + 1) = ArrA
               If UBound(ArrA, 1) > k Then k = UBound(ArrA, 1)
            End If
          Next a
          Sheets(1).UsedRange.EntireRow.AutoFit
          rng.Offset(, k) = Werte
          ActiveWorkbook.Close True
   Next j
End With

Fehler:
If Err.Number <> 0 Then MsgBox Err.Description
Set rng = Nothing
Application.ScreenUpdating = True

End Sub

Gruß Elex

[Leonhard]

Hi Elex,

bekomme den Fehler: Objektvariable oder Withblock-Variable nicht festgelegt.
habe deinen Code jetzt in ein Model einer leeren Excel gepackt, das ist schon richtig so, oder?

Beste Grüße
Leo

[Elex]

Hi

habe deinen Code jetzt in ein Model einer leeren Excel gepackt, das ist schon richtig so, oder?

Hatte ich gerade ergänzt. :19:

[Leonhard]

Hi Elex,

peeeeerfekt  :05: Vielen vielen Dank.
Wenn jetzt noch alle Rahmenlinien wieder gesetzt werden dann bin ich glaube hiermit wunschlos glücklich  :17:  

Nochmals vielen Dank & Grüße
Leo

[Elex]

Code:

Sub Leo()
Dim j As Long, a As Long, k As Long, rng As Range, Werte, ArrA

On Error GoTo Fehler
Application.ScreenUpdating = False

With Application.FileDialog(msoFileDialogOpen)  'Datei Auswahl Dialog
     .AllowMultiSelect = True   'Mehrfachauswahl
     .Show

   For j = 1 To .SelectedItems.Count    'Datein nacheinander öffnen
       Workbooks.Open (.SelectedItems(j))
        Set rng = Application.Intersect(Sheets(1).UsedRange, Range("D:XFD"))
          Werte = rng.Value
          rng.Clear
          k = 0
          For a = 20 To Cells(Rows.Count, 3).End(xlUp).Row
            If Cells(a, 3).Value <> "" Then
               ArrA = Split(Cells(a, 3), Chr(10))
               Cells(a, 3).Resize(, UBound(ArrA, 1) + 1) = ArrA
               If UBound(ArrA, 1) > k Then k = UBound(ArrA, 1)
            End If
          Next a
          rng.Offset(, k) = Werte
          Sheets(1).UsedRange.EntireRow.AutoFit
          Sheets(1).UsedRange.EntireColumn.AutoFit
          Sheets(1).UsedRange.SpecialCells(xlCellTypeConstants).Borders.LineStyle = xlContinuous
          ActiveWorkbook.Close True
   Next j
End With

Fehler:
If Err.Number <> 0 Then MsgBox Err.Description
Set rng = Nothing
Application.ScreenUpdating = True

End Sub

[Leonhard]

Hi elex,

ich müsste das usedRange durch Columns("C:BA") oder so ähnlich ersetzen. Also es sollen alle Zellen der neu eingefügten Spalten eingerahmt werden.
wenn du keine Lust mehr hast auch kein Beinbruch dann mache ich das zu Fuß =)

Besten Dank
Leo