Copying/pasting data & delete row up according to criteria

Hi all,

I have a macro which executes various subs in order. I'm having trouble with one part of it. Essentially I need some code which produces what is shown in the example worksheet.

Any ideas?

Try this code in a blank module -

Option Explicit
Dim lrow As Long
Dim lrow1 As Long
Dim i As Long

Sub clear_data()

With Worksheets("DataPrep")
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
lrow1 = .Range("B" & .Rows.Count).End(xlUp).Row

If lrow1 > lrow Then
    lrow = lrow1
End If

For i = 2 To lrow
    If Application.IsError(.Range("A" & i).Value) = True And Application.IsError(.Range("B" & i).Value) = False Then
        .Range("A" & i).Value = ""
    ElseIf Application.IsError(.Range("A" & i).Value) = False And Application.IsError(.Range("B" & i).Value) = True Then
        .Range("B" & i).Value = ""
    ElseIf Application.IsError(.Range("A" & i).Value) = True And Application.IsError(.Range("B" & i).Value) = True Then
        .Range("A" & i).Value = ""
        .Range("B" & i).Value = ""
    End If
Next i

ActiveWorkbook.Worksheets("DataPrep").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("DataPrep").Sort.SortFields.Add Key:=Range("A:A") _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("DataPrep").Sort
    .SetRange Range("A:A")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

ActiveWorkbook.Worksheets("DataPrep").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("DataPrep").Sort.SortFields.Add Key:=Range("B:B") _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("DataPrep").Sort
    .SetRange Range("B:B")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

End With

End Sub