VBA kopiere linjer mellem ark og springe dem over som indeholder xxx er langsom

Hejsa,

Jeg sidder med en prisfil der er på 30500 linjer og der ønsker jeg at lave en sortering når jeg kopierer noget af filen over i et andet ark.
Når jeg overfører, ændrer jeg på rækkefølgen af indholdet i kolonnerne.
Men der er nogle enheder jeg ikke ønsker at have med over i den nye fil.
Jeg ønsker fx kun at have linjer hvor enheden er "stk" og "mtr" overført til det andet ark.

Jeg bruger denne kode, men den tager meget, som i rigtig meget lang tid at køre, når der er over 30.000 linjer.
Hvis der er en der har et bud på en kode der kører hurtigere, vil jeg være meget taknemmelig.

Excel testfil kan hentes her (Dog ikke med 30.000 linjer):
http://46.32.50.245:8082/share.cgi?ssid=0vbdcT8


Sub Opret_Ny_Fil()
'
' Opret_Ny_Fil Makro
'

'
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim LR1 As Long, LR2 As Long, Lastrow As Long
   
   
    Set ws1 = Sheets("Leverandør")
    Set ws2 = Sheets("Ark2")
    ws2.Cells.ClearContents
     
       
    LR1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
       
    Application.ScreenUpdating = False
   
    LR2 = 1
   
    For i = 2 To LR1
     
       
        If ws1.Range("C" & i).Value = "stk" Or ws1.Range("C" & i).Value = "mtr" Then
            ws2.Cells.NumberFormat = "@"
            ws2.Cells(LR2, "A").Value = ws1.Cells(i, "H").Value
            ws2.Cells(LR2, "B").Value = ws1.Cells(i, "G").Value
            ws2.Cells(LR2, "C").Value = ("")
            ws2.Cells(LR2, "D").Value = ws1.Cells(i, "C").Value
            ws2.Cells(LR2, "E").Value = ws1.Cells(i, "D").Value
            ws2.Cells(LR2, "F").Value = ws1.Cells(i, "E").Value
            ws2.Cells(LR2, "G").Value = ("DKK")
            ws2.Cells(LR2, "H").Value = ws1.Cells(i, "E").Value
            ws2.Cells(LR2, "I").Value = ("DKK")
            ws2.Cells(LR2, "J").Value = ws1.Cells(i, "E").Value
            ws2.Cells(LR2, "K").Value = ("DKK")
            ws2.Cells(LR2, "L").Value = ws1.Cells(i, "E").Value
            ws2.Cells(LR2, "M").Value = ("DKK")
            ws2.Cells(LR2, "N").Value = ws1.Cells(i, "E").Value
            ws2.Cells(LR2, "O").Value = ("DKK")
           
            Worksheets("Ark2").Columns("A:CC").AutoFit
           
            LR2 = LR2 + 1
         
        End If
        Next i
       
       
           
        Worksheets("Ark2").Columns("E").NumberFormat = "0.00"
        Worksheets("Ark2").Columns("F").NumberFormat = "0.00"
        Worksheets("Ark2").Columns("H").NumberFormat = "0.00"
        Worksheets("Ark2").Columns("J").NumberFormat = "0.00"
        Worksheets("Ark2").Columns("L").NumberFormat = "0.00"
        Worksheets("Ark2").Columns("N").NumberFormat = "0.00"
       
       
Application.ScreenUpdating = True

MsgBox "Filen er klar!"

End Sub