Optimering af VBA kode for bedre hastighed

Hejsa
Jeg har forholdsvis ny i VBA kode sammenhæng.
Jeg har lavet noget kode i VBA for Excel, der samler data fra flere rækker på en, afhængig af en værdi i en bestemt kolonne.

Efterfølgende skal de øvrige rækker slettes.
Men det tog alt alt for lang tid at slette disse rækker i mit Loop. Derfor har jeg ændret kode så disse rækker markeres med "S" og sluttelig i koden slettes disse rækker så.

Min datamængde er på ca. 150.000 rækker.
Jeg har lavet en test med 1500 rækker og det tager 4 min. som koden er nu. Det vil derfor betyde at det tager 6,5 time at køre denne makro.

Håber der en der kan hjælpe med at optimere koden yderligere.

På forhånd tak.


Sub Saml_Linier()
Dim Slutrække As Long
Dim startcelle As String
Dim startrække As Long
Dim i As Long
Dim vaerdi As String
Dim vaerdi2 As String

Application.ScreenUpdating = False

Sheets("FS").Select
starttid = Time
    Columns("A:A").Select
    Selection.ClearContents
   
    Columns("L:M").Select
    Selection.ClearContents
   
    Columns("V:V").Select
    Selection.ClearContents
   
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "=RC[3]&"" ""&RC[4]&"" ""&RC[5]"

    Range("B2").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, -1).Select
    ActiveCell.FormulaR1C1 = "x"
    Range("A2").Select
    Selection.Copy
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False

    Range("C2").Select
    Slutrække = ActiveCell.Row
    Selection.End(xlDown).Select
   
    ' Her findes start række nr.
    startcelle = ActiveCell.Address()
    startrække = ActiveCell.Row
 
    i = ActiveCell.Row()
    ActiveCell.Offset(1, 0).Select
    vaerdi = ActiveCell
    Range(startcelle).Select
   
Do
  Do While i > Slutrække - 1
   
    If ActiveCell = vaerdi Then
      vaerdi2 = ActiveCell
      tilbagetilCelle = ActiveCell.Address()
      ActiveCell.Offset(0, 9) = ActiveCell.Offset(1, 4).Value
   
      If ActiveCell.Offset(1, 9) <> "" Then
        ActiveCell.Offset(0, 10) = ActiveCell.Offset(1, 9).Value
      End If
   
      If vaerdi2 <> "" Then
        ActiveCell.Offset(1, 19) = "S"
      End If
       
    End If
    vaerdi = ActiveCell
    If ActiveCell.Row > 1 Then
      ActiveCell.Offset(-1, 0).Activate
    End If
    i = ActiveCell.Row()
  Loop
  Loop Until Slutrække = i + 1
 
   
  ' Her sorteres kolonne 3 for at finde de rækker der skal slettes
  ActiveWorkbook.Worksheets("FS").ListObjects("Tabel_Forespørgsel_fra_AVIS").Sort _
        .SortFields.Add Key:=Range("Tabel_Forespørgsel_fra_AVIS[Kolonne3]"), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("FS").ListObjects("Tabel_Forespørgsel_fra_AVIS") _
        .Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
' Her findes rækker markeret med S, og slettes

    Range("V2").Select
    Selection.End(xlDown).Select
    Start = 2
    slut = ActiveCell.Row
    Range("A2").Select
    rækker = Start & ":" & slut
    Rows(rækker).Select
    Selection.Delete Shift:=xlUp

sluttid = Time
MsgBox "Det tog " & DateDiff("n", starttid, sluttid) & "minutter"

End Sub