Makro kürzen, vereinfachen

Sub neuer_Zugang()
Range("IV1") = "1"
Sheets("Daten").Range("IV1") = "1"
Range("AH4").Select
' neue Daten kennzeichnen
Do While ActiveCell <> ""
ActiveCell.Offset(0, 222) = "neu"
ActiveCell.Offset(1, 0).Select
Loop
' Bestand zu neuen dazu und sortieren
Sheets("Daten").Range("AH4:AI1994").Copy
Sheets("Zugang").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Rows("4:452").Select
Selection.Sort Key1:=Range("AH4"), Order1:=xlAscending, Key2:=Range("AI5" _
), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
Columns("IV:IV").Select
Do While Range("IV1") <> ""
' Stellen der neuen finden und in den verknüpften Tabellen richtig einsetzen
On Error GoTo weiter
Sheets("Zugang").Select
Columns("IV:IV").Select
Selection.Find(What:="neu", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
zeile = ActiveCell.Row
ActiveCell = ""
Rows(ActiveCell.Row).Copy
Sheets(Array("Daten", "Zahlungen", "DTSA Liste", "TK Belegung")).Select
Rows(zeile).Select
Rows(zeile).Insert Shift:=xlDown
Loop
weiter:
On Error GoTo 0
Range("IV1") = ""
' Verknüpfungen der anderen Tabellen nach oben und unten ziehen
Sheets("Daten").Range("IV1") = ""
Sheets("Zahlungen").Select
Range("A5:G5").Select
Selection.AutoFill Destination:=Range("A4:G5"), Type:=xlFillDefault
Range("A4:G5").Select
Selection.AutoFill Destination:=Range("A4:G226"), Type:=xlFillDefault
Range("A4:G226").Select
Sheets("DTSA Liste").Select
Columns("A:A").Select
Selection.Find(What:="Summe", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
zelle = ActiveCell.Offset(-1, 0).Row
Range("A3:K3").Select
Selection.AutoFill Destination:=Range("A2:K3"), Type:=xlFillDefault
Range("A2:K3").Select
Range("A2").FormulaR1C1 = "1"
Range("A3:K3").Select
Selection.AutoFill Destination:=Range("A3:K" & zelle), Type:=xlFillDefault
Range("A3:K254").Select
Sheets("TK Belegung").Select
Range("A4:V4").Select
Selection.AutoFill Destination:=Range("A3:V4"), Type:=xlFillDefault
Range("A3:V4").Select
Range("A3").Select
ActiveCell.FormulaR1C1 = "1"
Range("A4").Select
ActiveCell.FormulaR1C1 = "=IF(RC[1]="""","""",R[-1]C+1)"
Range("A4:V4").Select
Selection.AutoFill Destination:=Range("A4:V673"), Type:=xlFillDefault
End Sub