Sub f()
    Dim rng As Range, rng2 As Range, rng3 As Range, i As Long
    Set rng = Cells.Find(What:="Product Name",  LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=True)
    If rng Is Nothing Then Exit Sub
    For i = rng.Row +  1  To Worksheets(rng.Parent.Name).UsedRange.Rows.Count
        If Cells(i, rng.Column) = "" And Cells(i, rng.Column +  1 ) = "" Then
            If rng2 Is Nothing Then
                Set rng2 = Cells(i, rng.Column)
            Else
                Set rng2 = Union(rng2, Cells(i, rng.Column))
            End If
        ElseIf Cells(i, rng.Column) = "" Then
            Cells(i, rng.Column) = rng3
        Else
            Set rng3 = Cells(i, rng.Column)
        End If
    Next
    rng2.EntireRow.Delete
End Sub

Worksheets(rng.Parent.Name)=rng.Worksheet

Sub Test()
    Dim rng As Range
    Set rng = Worksheets.Add(, Worksheets("Sheet1")).[A1]
    With Worksheets("Sheet1")
        Intersect(.[A:B], .[B:B].SpecialCells(xlCellTypeConstants).EntireRow).Copy rng
    End With
    With rng.CurrentRegion.SpecialCells(xlCellTypeBlanks)
        .Value = "=R[-1]C"
        .Value = .Value
    End With
End Sub

        .Value = .Value