Search values and copy to specific sheet & cells

Maybe:

Sub keis386ZZZ()
Dim rcell As Range
For Each rcell In Range("C3:C" & ActiveSheet.UsedRange.Rows.count + 1)
    Select Case rcell.Value
        Case Is = "VS"
            rcell.Copy Sheets("VS").Range("A" & Rows.count).End(3)(2)
            rcell.Offset(, 1).Copy Sheets("VS").Range("C" & Rows.count).End(3)(2)
        Case Is = "LND"
            rcell.Copy Sheets("LND").Range("A" & Rows.count).End(3)(2)
            rcell.Offset(, 1).Copy Sheets("LND").Range("C" & Rows.count).End(3)(2)
    End Select
Next rcell
End Sub

Thanks a lot for your help!

I still have one small question.
I added one column E, if value in same row is 570 values should not be copied,is that possible?
I added an updated excel file

Much appreciated!

Maybe:

Sub keis386ZZZ()
Dim rcell As Range
For Each rcell In Range("C3:C" & ActiveSheet.UsedRange.Rows.count + 1)
    Select Case rcell.Value
        Case Is = "VS"
            If rcell.Offset(, 2).Value <> 570 Then
            rcell.Copy Sheets("VS").Range("A" & Rows.count).End(3)(2)
            rcell.Offset(, 1).Copy Sheets("VS").Range("C" & Rows.count).End(3)(2)
            End If
        Case Is = "LND"
            If rcell.Offset(, 2).Value <> 570 Then
            rcell.Copy Sheets("LND").Range("A" & Rows.count).End(3)(2)
            rcell.Offset(, 1).Copy Sheets("LND").Range("C" & Rows.count).End(3)(2)
            End If
    End Select
Next rcell
End Sub