Sætte farten op på en kode

Jeg har en kode der henter data fra fra ark "2008" til arket "timesedler"

Koden virker godt nok, men jeg kunne godt bruge at den blev speedet lidt op da den skal løbe op til 100.000 linjer igennem.

Jeg er klar over at den kan køres på meget kort tid, hvis blot den bliver læst korrekt ind i arrays.

Jeg har forsøgt alt muligt men kan ikke få den forbedret.

Som I kan se i koden nedenfor er der 3 kriterier der er gældende
Området "timesedler_fradato"  (feks. 01-01-2008)
Området "timesedler_tildato"  (feks. 30-06-2008)
Området "timesedler_init"  (tal fra 1 til 10)

Er der nogen der kan hjælpe mig med at få den speedet lidt op?


Sub timesedler_hent_udfra_dato()
   
    Dim intI As Integer
    Dim intJ As Integer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
   
    Rows("5:5000").Select
    Selection.Delete Shift:=xlUp
    Range("a1").Select
   
    Set shtime = ThisWorkbook.Sheets("timesedler")
    Set sh2008 = ThisWorkbook.Sheets("2008")
    Set shstam = ThisWorkbook.Sheets("stam")
   
    intJ = 5
    Do Until (ThisWorkbook.Sheets("timesedler").Cells.Range("B" & intJ) = "")
        intJ = intJ + 1
    Loop
   
    rk08 = sh2008.Cells(250000, "B").End(xlUp).Row
    initial = shstam.Range("timesedler_init")
    x = Application.CountIf(sh2008.Range("D5:D" & rk08), initial)
    RK = 4
 
    For intI = 5 To x
      rk1 = sh2008.Range("D" & RK & ":D250000").Find(revinit, LookIn:=xlValues, LookAt:=xlWhole).Row
      RK = rk1
     
    If sh2008.Cells.Range("C" & RK) >= shstam.Cells.Range("timesedler_fradato") And _
        sh2008.Cells.Range("C" & RK) <= shstam.Cells.Range("timesedler_tildato") Then
       
        sh2008.Range("A" & RK & ":T" & RK).Copy shtime.Range("A" & intJ)
       
        intJ = intJ + 1
        End If
        'Application.StatusBar = "Henter data fra " & x & " linjer!"
  Next
 
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
   
End Sub


ALTERNATIV KODE SOM IKKE VIRKER

Sub timesedler_hent_udfra_dato_ny_test()
    Dim RW As Long, Data1 As Variant
    Dim intI As Integer

    RW = ThisWorkbook.Sheets("2008").Range("S65536").End(xlUp).Row
    Data1 = ThisWorkbook.Sheets("2008").Range("C5:D" & RW)
    For intI = 1 To UBound(Data1)
        If Data1(intI, 1) >= Sheets("stam").Range("timesedler_fradato") And Data1(intI, 1) <= Sheets("stam").Range("timesedler_tildato") Then
            ThisWorkbook.Sheets("2008").Cells.Range("A" & intI & ":T" & intI).Copy ThisWorkbook.Sheets("timesedler").Range("A" & intJ)
        End If
    Next intI
End Sub