Sub Move()
Const strTest = "RJ"
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim rngCells As Range
Dim rngFind As Range
    
    Set wsSource = ActiveSheet
    
    NoRows = wsSource.Range("A65536").End(xlUp).Row
    DestNoRows = 1
    
    'create sheet RJ
    Set wsDest = ActiveWorkbook.Worksheets.Add(After:=Sheets(Sheets.Count))
    ActiveWorkbook.Sheets(Worksheets.Count).Name = strTest
        
    For I = 1 To NoRows
    
        Set rngCells = wsSource.Range("C" & I & ":F" & I)
        
        If Not (rngCells.Find(strTest) Is Nothing) Then
            rngCells.EntireRow.Cut wsDest.Range("A" & DestNoRows)
            
            DestNoRows = DestNoRows + 1
        End If
    Next I
End Sub

Dim sourceRng As Range
    Dim cell As Range
    Set sourceRng = Sheets("Info").Range("Deli[Unit]")
    For Each cell In sourceRng
        If cell.Value > 0 Then
            Sheets("Info").ListObjects("Deli").Range.Copy
    With Sheets("Other").Range("A" & Rows.Count).End(xlUp).Offset(0, 0)
    .PasteSpecial xlPasteAllUsingSourceTheme
    .PasteSpecial xlPasteColumnWidths
    End With
        End If
    Next cell

Range("Deli").Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

    ActiveSheet.ListObjects("Main").Range.AutoFilter Field:=3, Criteria1:= _
        "Versandkosten"
    ActiveSheet.ListObjects("Main").Range.AutoFilter Field:=2, Criteria1:= _
        "<NL> <Nebenleistung>"