Clever-Excel-Forum

Seiten: 1 2

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 Blush

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 Angel

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

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

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

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

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

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

Hatte ich gerade ergänzt. :19:

Hi Elex,

peeeeerfekt Blush

: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

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

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

Seiten: 1 2

Leonhard

LCohen

Leonhard

LCohen

Elex

Leonhard

Elex

Leonhard

Elex

Leonhard