Okay, you can see my macro below this text. I am still having
problems, the macro only runs one loop and then stops, I must be
missing something... It doesn't report and error and functions as it
should but it doens't loop they way I hoped...
I would like it to loop until it has cut every row out with data in
Range(A9:A100)
:-)

Sub Optimer()
Sheets("CM").Select
Dim cell As Range
Dim rng As Range
Range("A9:F35").Sort Key1:=Range("B9"), Order1:=xlDescending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

myValue = Range("J3").Value
For i = 1 To Application.WorksheetFunction.Count(Range("A9:A100 "))
For Each cell In Range("B9:B35")
If Range("B9:B35").Rows.Count <
Application.WorksheetFunction.CountBlank(Range("B9 :B35")) Then
If cell.Value < myValue Then
cell.Select
ActiveCell.EntireRow.Select
Selection.Cut
Sheets("Dataark").Select
Range("A3").Select
Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas,
LookAt:=xlPart, Searchorder:=xlByColumns, SearchDirection:=xlNext,
MatchCase:=False, SearchFormat:=False).Activate
ActiveSheet.Paste
Set rng = Cells(Rows.Count, 2).End(xlUp)
rng.Select
ActiveCell.Copy
Sheets("CM").Select
Range("K3").Select
ActiveSheet.Paste
Selection.Font.ColorIndex = 2
Range("J3").Select
ActiveCell.FormulaR1C1 = "=R[1]C[-8]-RC[1]"
Exit Sub
End If
End If
Next cell
Next i
End Sub




//Kasper