Sub es()
Dim t(), t1(), x As Long, i As Long, a As Variant, z As Long
t = Range("b1:b" & Cells(Rows.Count, 2).End(xlUp).Row)
a = Array(" all ", " av ", " r ", " imp ", " chem ", " pl ", " bd ", " bld ")
ReDim t1(1 To UBound(t), 1 To 1)
For i = 1 To UBound(t)
x = x + 1
For z = LBound(a) To UBound(a)
t(i, 1) = Right(t(i, 1), Len(t(i, 1)) - InStr(t(i, 1), a(z)) + 1)
Next z
t1(x, 1) = t(i, 1)
Next i
[b1].Resize(x, 1) = t1
End Sub