Compare fields and if match found move data and delete row

I need a vba solution for the following:

I have a spreadsheet where I need to compare fields in columns A & B and if they match one another then remove the duplicates but put the data from the duplicates in columns d & f. I have attached an example of what I am looking for. Any help would be appreciated.


[attach]example.xlsx[/attach]



Thanks,

Met

Try

Sub test()
    Dim a, i As Long, ii As Long, txt As String, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    a = Sheets("data").Cells(1).CurrentRegion.Resize(, 7).Value
    ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 1)
    For i = 1 To UBound(a, 1)
        txt = Join(Array(a(i, 1), a(i, 2), a(i, 6), a(i, 7)), Chr(2))
        If Not dic.exists(txt) Then
            dic(txt) = dic.Count + 1: a(dic.Count, UBound(a, 2)) = 3
            For ii = 1 To UBound(a, 2) - 1
                a(dic.Count, ii) = a(i, ii)
            Next
        Else
            a(dic(txt), UBound(a, 2)) = a(dic(txt), UBound(a, 2)) + 1
            a(dic(txt), a(dic(txt), UBound(a, 2))) = a(i, 3)
        End If
    Next
    Sheets.Add.Cells(1).Resize(dic.Count, UBound(a, 2) - 1).Value = a
End Sub

Thanks that did it.

Met