Sub CodePostal()
Dim o As Object, tablo, i&, a
Set o = CreateObject("vbscript.regexp")
o.Global = True
o.Pattern = "\d{5}"
With [A1].CurrentRegion.Resize(, 2)
tablo = .Value
For i = 1 To UBound(tablo)
Set a = o.Execute(tablo(i, 1))
If a.Count Then tablo(i, 2) = a(0) Else tablo(i, 2) = ""
Next
.Value = tablo
End With
End Sub