Sub NumbQuant()
  Dim r&, a, d, k
  a = Worksheets(1).UsedRange: k = Cells(4, 2)
  Set d = CreateObject("Scripting.Dictionary")
  For r = 2 To UBound(a)
    If a(r, 3) = k Then If Not d.exists(a(r, 12)) Then d(a(r, 12)) = a(r, 8)
  Next
  If d.Count = 0 Then Exit Sub Else r = Cells(Rows.Count, 2).End(xlUp).Row
  If r > 7 Then Cells(8, 2).Resize(r - 7, 2).ClearContents
  Cells(8, 2).Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
  Cells(8, 3).Resize(d.Count, 1) = WorksheetFunction.Transpose(d.items)
End Sub