Sub test()
'-----------------------------------
    Dim arr(), i&, j&, x&
'-----------------------------------
    With Worksheets("Лист1")
        i = .Range("a" & .Rows.Count).End(xlUp).Row
        j = .Cells(1, .Columns.Count).End(xlToLeft).Column
        arr = .Range(.Cells(1, 1), .Cells(i, j)).Value
        x = 1
        For i = 2 To UBound(arr)
            If arr(i, 1) = "Свёкла" Then
                x = x + 1
                For j = 1 To UBound(arr, 2)
                    arr(x, j) = arr(i, j)
                Next j
            End If
        Next i
        .[f1].Resize(x, UBound(arr, 2)).Value = arr
    End With
End Sub