AW: Zellen einrücken gemäß Überschriften
03.10.2018 21:23:29
Daniel
Hi
warum immer nur um eine Zelle verschieben?
platziere die Werte doch gleich an die richtige Stelle.
der Versatzwert ergibt sich aus der Differenz zwischen dem Datum in der Zelle und dem Datum in Zeile 1 (sofern dort die Datumswerte lückenlos stehen)
wenn man davon ausgehen kann, dass die Zielzelle immer frei ist, reicht dieser Code:
Sub ZellenEinrücken2()
Dim Zelle As Range
For Each Zelle In Range(Cells(3, 2), Cells.SpecialCells(xlCellTypeLastCell)).SpecialCells( _
xlCellTypeConstants, 1)
Zelle.Cut Zelle.Offset(0, Zelle.Value - Cells(1, Zelle.Column).Value)
Next
End Sub
wenn man damit rechnen muss, dass die Zielzelle durch einen anderen Wert, der noch nicht verschoben wurde belegt ist, müsste man das vorher prüfen, der Code wird dann aufwendiger.
Daher hier nochmal eine Lösungsvariante mit Arrays, bei der dieses Problem nicht auftritt, weil das Ergebnis in ein zunächst leeres Array geschrieben wird.
Der Trick hierbei ist, dass im Ergebnisarray die Datumswerte als Spaltenindex verwendet werden, so dass man das Ziel nicht aufwendig suchen muss, sondern es sich direkt aus dem Wert ergibt:
Sub ZelleEinrücken3()
Dim arrDaten
Dim arrErg
Dim z As Long, s As Long
Dim rng As Range
Set rng = Range(Cells(3, 1), Cells(3, 1).End(xlDown)).Resize(, Cells(1, 1).End(xlToRight). _
Column)
arrDaten = rng.Value
ReDim arrErg(1 To UBound(arrDaten, 1), Cells(1, 1).Value To Cells(1, 1).End(xlToRight).Value)
For z = 1 To UBound(arrDaten, 1)
For s = 1 To UBound(arrDaten, 2)
If IsDate(arrDaten(z, s)) Then
arrErg(z, arrDaten(z, s)) = arrDaten(z, s)
End If
Next
Next
rng.Value = arrErg
End Sub
Gruß Daniel