Hallo alle,

habe das Problem dass die innere Schleife in folgendem Makro jeweils 3 Zeilen vor der letzten Zeile aus sich raus springt und somit nicht verschobene Zellen zurück bleiben. Dabei sollte sie von Rechts nach Links die Spalten durchlaufen (Do While) und innerhalb jeweils Zellen verschieben. Die innere Schleife springt unabhängig vom Rechner oder der Tabellenbefüllung jeweils 3 Zeilen vor der letzten befüllten Zeile aus sich raus.

Hoffentlich könnt Ihr mir helfen, vielen Dank dafür!

__________________________________________

Makro:

--------------------------------------------------------------------------

Option Explicit

Sub RemoveMultipleTypes()
Dim lastRow, lastColumn As Integer
Dim i As Long

    lastColumn = Sheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Column
    lastRow = Sheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row
    '2 Schleifen: 1 die Zeilen durchläuft, 1 die Spalten (von hinten durchläuft -> From MAX(Spaltenindex) TO erste Spalte
    'äußere Schleife: Spalten von rechts nach Links durchlaufen
    'innere Schleife: Zeilen von oben nach unten durchlaufen
    lastColumn = 10
    Do While lastColumn > 8 'äußere Schleife über Spalten, nur bis 9 da Spalten nur bis H sortiert werden sollen

        For i = 2 To lastRow 'innere Schleife über Zeilen, ab 2 da Überschrift nicht sortiert werden solls
            'wenn aktuelle Zelle (Schnitt aus Spalten- und Zeilen-Index) nicht leer ist, dann mach eine neue leere Zeile unterhalb und kopiere die aktuelle Zelle in die Zeile darunter an in Spalte H
            If Len(Cells(i, lastColumn)) = 0 Then
                'NOP
                Cells(i, lastColumn).Select
            Else
                Cells(i, lastColumn).Select
                Cells(i + 1, lastColumn).EntireRow.Insert
                Cells(i, lastColumn).Cut Destination:=Cells(i + 1, 8)
            End If
            lastRow = Sheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row 'da eventuell Zeilen hinzugefügt wurden muss die letzte Reihe wieder neu ermittelt werden
            MsgBox ("Aktuelle Zelle: " & CStr(i) & " " & CStr(lastColumn) & "     -     aktuell i|lastRow:" & CStr(i) & " " & CStr(lastRow))
        Next
        lastColumn = lastColumn - 1 'dekrement Spalten
    Loop
   
End Sub