copy code have different price and count

help me to copy code have different price and count like example in attachment

Option Explicit

Sub test()
    Dim a, i As Long, txt As String, w, y, n As Long
    a = Sheets("data set (2)").Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            txt = Join$(Array(a(i, 1), a(i, 2)), Chr(2))
            If Not .exists(txt) Then
                .Item(txt) = VBA.Array(a(i, 1), a(i, 2), 1)
            Else
                w = .Item(txt)
                w(2) = w(2) + 1
                .Item(txt) = w
            End If
        Next
        y = .items: n = .Count
    End With
    With Sheets("out put").Cells(1).Resize(n, 3)
        .CurrentRegion.ClearContents
        .Columns(1).NumberFormat = "@"
        .Value = Application.Transpose(Application.Transpose(y))
        .Cells(1, 3).Value = "Count"
        .Columns.AutoFit
    End With
End Sub

in your code also give me the code that don't have different price I need to give me the code have different price only

Option Explicit

Sub test()
    Dim a, i As Long, w, n As Long, e, s
    a = Sheets("data set (2)").Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                Set .Item(a(i, 1)) = _
                CreateObject("Scripting.Dictionary")
            End If
            If Not .Item(a(i, 1)).exists(a(i, 2)) Then
                .Item(a(i, 1))(a(i, 2)) = VBA.Array(a(i, 1), a(i, 2), 1)
            Else
                w = .Item(a(i, 1))(a(i, 2))
                w(2) = w(2) + 1
                .Item(a(i, 1))(a(i, 2)) = w
            End If
        Next
        ReDim Preserve a(1 To UBound(a, 1), 1 To 3)
        a(1, 3) = "Count": n = 1
        For Each e In .keys
            If .Item(e).Count < 2 Then
                .Remove e
            Else
                For Each s In .Item(e).keys
                    n = n + 1
                    For i = 0 To 2
                        a(n, i + 1) = .Item(e)(s)(i)
                    Next
                Next
            End If
        Next
    End With
    With Sheets("out put").Cells(1).Resize(n, 3)
        .CurrentRegion.ClearContents
        .Columns(1).NumberFormat = "@"
        .Value = a
        .Columns.AutoFit
    End With
End Sub

THaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaank's alot will done