Die Datei https://www.herber.de/bbs/user/28082.xls wurde aus Datenschutzgründen gelöscht
dabei rauskommt?
Sub x()
Dim i&, z&, x&, lz%
z = 25
x = 24
Application.ScreenUpdating = False
[b3:d24].Copy [j3]
Do While z > 5
For i = x To 5 Step -1
If Cells(z, 12) = Cells(i, 12) Then
Range(Cells(i, 10), Cells(i, 12)).Delete shift:=xlUp
End If
If Cells(z, 12) <> Cells(i, 12) Then
GoTo y
End If
Next
y:
z = z - 1
x = x - 1
Loop
lz = Cells(Rows.Count, 11).End(xlUp).Row
Range(Cells(5, 10), Cells(lz, 10)).Copy Cells(5, 11)
[b5].Copy [j5]
For i = 6 To lz
Cells(i, 10) = Cells(i - 1, 11) + 1
Next
Application.ScreenUpdating = False
End Sub
Sub supersort()
Dim SP%, NP%, ER%, LR%, I#, Z#
'Anpassungsbereich
SP = 4 'Ursprung in Spalte D
ER = 5 'erste Zeile der Ausgangswerte (ab Zeile 5)
NP = 6 ' Neue Werte ab Spalte F
Z = 5 'Neue Werte ab Zeile 5
'Bereich löschen und Spaltenköpfe setzen
Range(Columns(NP), Columns(NP + 2)).ClearContents
Cells(Z - 2, NP) = "vom"
Cells(Z - 2, NP + 1) = "bis"
Cells(Z - 2, NP + 2) = "Ort"
LR = Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
For I = ER To LR
If Cells(Z, NP) = "" Then Cells(Z, NP) = Cells(I, SP - 2) 'Wenn leer dann Von setzen
Cells(Z, NP + 1) = Cells(I, SP - 2) 'Bis setzen (immer)
Cells(Z, NP + 2) = Cells(I, SP) 'Ort setzen (immer)
If Cells(I, SP) <> Cells(I + 1, SP) Then
Z = Z + 1 'Nächste Zeile
End If
Next
End Sub
Die Datei https://www.herber.de/bbs/user/28057.xls wurde aus Datenschutzgründen gelöscht
meine eigentliche Datei.