Sub Adresses()
Dim tablo, ad$(), i&, t$, s, ub%, j%
tablo = Range("A2:A3", Cells(Rows.Count, 1).End(xlUp))
ReDim ad(1 To UBound(tablo), 1 To 2)
For i = 1 To UBound(tablo)
t = Replace(tablo(i, 1), ".", " ") 'point remplacé
t = Replace(t, ",", "") 'suppression virgule
t = Application.Trim(t) 'SUPPRESPACE
s = Split(t)
ub = UBound(s)
If ub >= 0 Then
For j = 0 To ub
If s(j) Like "*#*" Then
ad(i, 2) = s(j)
If j Then If LCase(s(j - 1)) Like "ap*t" Or Len(s(j - 1)) < 3 _
Then ad(i, 2) = s(j - 1) & " " & s(j) 'appartement ou N°
If j < ub Then If Len(s(j + 1)) = 1 Or IsNumeric(s(j + 1)) _
Then ad(i, 2) = ad(i, 2) & " " & s(j + 1) 'caractères isolés
ad(i, 1) = Application.Trim(Replace(t, ad(i, 2), "", , 1))
Exit For
End If
ad(i, 1) = t
Next
End If
Next
[B2:C2].Resize(UBound(ad)) = ad
Range("B" & UBound(ad) + 2 & ":C" & Rows.Count).ClearContents
End Sub