Sub test()
Dim a, result(), i As Long, z As String, n As Long
a = Range("a1").CurrentRegion.Resize(,2).Value
ReDim result(1 To UBound(a,1), 1 To 2)
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 2 To UBound(a,1)
If Not IsEmpty(a(i,1)) Then
z = Left(a(i,1),2)
If Not .exists(z) Then
n = n + 1
result(n,1) = z
result(n,2) = a(i,2)
Else
x = .item(z)
If InStr(1,result(x,2),"High",vbTextCompare) = 0 Then
If InStr(1,a(i,2),"High",vbTextCompare) > 0 Then
result(x,2) = a(i,2)
ElseIf InStr(1, a(i,2), "Med",vbTextCompare) > 0 Then
result(x,2) = a(i,2)
End If
End If
End If
End If
Next
End With
Range("e1").Resize(n,2) = result
End Sub