Kode optimering,

Jeg har et stykke slave kode der flytter lidt rundt på lidt data og skriver dem op på en måde som jeg kan bruge længere nede i systemet.. men den er blevet lidt tung at danse med. da der er ca 38000 linjer der alle skal deles i to

Sub datahandler3()
Dim r As Long
Dim lngRowsProject As Long
Dim t As Long
Dim s As Long
Dim v As Long

Worksheets.Add(After:=Worksheets(2)).Name = "Dataholder"

Sheets("DATA").Select

lngRowsProject = Application.CountA(Range("A:A"))

t = 1

For r = 1 To lngRowsProject Step 1
If Range("B" & r).Value > 0 Then
    'location
    Range("A" & r).Select
    Selection.Copy
    Sheets("Dataholder").Select
    Range("A" & t).Select
    ActiveSheet.Paste
    Sheets(2).Select
    'planning
    '---
    'Plan
    '---
    'Period
    '---
    'ruleset
    '---
    'Rooms type
    Range("D1").Select
    Selection.Copy
    Sheets("Dataholder").Select
    Range("F" & t).Select
    ActiveSheet.Paste
    Sheets(2).Select
    'date
    Range("D" & r).Select
    Selection.Copy
    Sheets("Dataholder").Select
    Range("G" & t).Select
    ActiveSheet.Paste
    Sheets(2).Select
    'Value
    Range("C" & r).Select
    Selection.Copy
    Sheets("Dataholder").Select
    Range("H" & t).Select
    ActiveSheet.Paste
    Sheets(2).Select
    t = t + 1

End If
Next r
For s = 1 To lngRowsProject Step 1
If Range("C" & s).Value > 0 Then
    'location
    Range("A" & s).Select
    Selection.Copy
    Sheets("Dataholder").Select
    Range("A" & t).Select
    ActiveSheet.Paste
    Sheets(2).Select
    'planning
    '---
    'Plan
    '---
    'Period
    '---
    'ruleset
    '---
    'Rooms type
    Range("E1").Select
    Selection.Copy
    Sheets("Dataholder").Select
    Range("F" & t).Select
    ActiveSheet.Paste
    Sheets(2).Select
    'date
    Range("E" & s).Select
    Selection.Copy
    Sheets("Dataholder").Select
    Range("G" & t).Select
    ActiveSheet.Paste
    Sheets(2).Select
    'Value
    Range("C" & s).Select
    Selection.Copy
    Sheets("Dataholder").Select
    Range("H" & t).Select
    ActiveSheet.Paste
    Sheets(2).Select
    t = t + 1

End If
Next s


Sheets("Dataholder").Select
Range("A1", "H" & t).Select

Selection.Copy
ActiveWorkbook.Close False
ThisWorkbook.Activate
Sheets("12 month").Select
Range("a1000000").Select
Selection.End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste

End Sub