flytning af rækker til andet ark ud fra kriterier i det første ar

Du kan forsøge med denne:

Dim i, o As Integer

o = 1
Sheets("Ark1").Select

For i = 50 To 1 Step -1
    Cells(i, 4).Select
    If ActiveCell.Value = "TTJ" Or ActiveCell.Value = "KSP" Then
        Range(i & ":" & i).Select
        Selection.Cut
        Sheets("Ark2").Select
        Cells(o, 1).Select
        ActiveSheet.Paste
        o = o + 1
        Sheets("Ark1").Select
        Selection.Delete Shift:=xlUp
    End If
Next i

Pastet i modsat rækkefølge:

Dim i, o, p, c As Integer

Sheets("Ark1").Select

For p = 1 To 50
    If UCase(Cells(p, 4).Value) = "TTJ" Or UCase(Cells(p, 4).Value) = "KSP" Then
        c = c + 1
    End If
Next p

o = 1

For i = 50 To 1 Step -1
    Cells(i, 4).Select
    If UCase(ActiveCell.Value) = "TTJ" Or UCase(ActiveCell.Value) = "KSP" Then
        Range(i & ":" & i).Select
        Selection.Cut
        Sheets("Ark2").Select
        Cells(c, 1).Select
        ActiveSheet.Paste
        c = c - 1
        o = o + 1
        Sheets("Ark1").Select
        Selection.Delete Shift:=xlUp
    End If
Next i

prøvet begge men lidt problem. Jeg tror nummer to er bedst men den skal kopiere rækkerne og ikke flytte dem. DE forsvinder fra det første ark
Tim

jeg har rettet lidt, så den passer til min ark
Sub ryg()
Dim i, o, p, c As Integer

Sheets("Sheet1").Select

For p = 3 To 64
    If UCase(Cells(p, 17).Value) = "TTJ" Or UCase(Cells(p, 17).Value) = "KPS" Then
        c = c + 1
    End If
Next p

o = 1

For i = 50 To 1 Step -1
    Cells(i, 17).Select
    If UCase(ActiveCell.Value) = "TTJ" Or UCase(ActiveCell.Value) = "KPS" Then
        Range(i & ":" & i).Select
        Selection.Cut
        Sheets("Rygpatienter").Select
        Cells(c, 1).Select
        ActiveSheet.Paste
        c = c - 1
        o = o + 1
        Sheets("Sheet1").Select
        Selection.Delete Shift:=xlUp
    End If
Next i
End Sub

Så er der ingen grund til at loope baglæns eller tælle antal forekomster:

Dim i, c As Integer
c = 1

Sheets("Ark1").Select

For i = 3 To 64
    If UCase(Cells(i, 4).Value) = "TTJ" Or UCase(Cells(i, 4).Value) = "KSP" Then
        Range(i & ":" & i).Copy
        Sheets("Ark2").Select
        Cells(c, 1).Select
        ActiveSheet.Paste
        c = c + 1
        Sheets("Ark1").Select
        Application.CutCopyMode = False
    End If
Next i

Ja nu virker den uden problemer.

Mange tak for din endnu engang - smukt arbejde

Send et svar!!

mvh
Tim

Kommer hér ;)) Takker!