Microsoft 365 Scinder une cellule en plusieurs...

Sub Scinder()
Dim tablo, resu(), i&, n&, x$, j%, k%
With [A5].CurrentRegion
    tablo = .Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    If UBound(tablo) = 1 Then Exit Sub
    ReDim resu(1 To UBound(tablo) - 1, 1 To 3)
    For i = 2 To UBound(tablo)
        n = n + 1
        x = tablo(i, 2)
        j = InStr(x, " ")
        resu(n, 1) = RTrim(Left(x, j))
        k = InStr(x, ":")
        resu(n, 3) = Val(Mid(x, j + 1))
        If k > j + 1 Then
            resu(n, 2) = Mid(x, k)
            resu(n, 3) = LTrim(Mid(x, j + 1, k - j - 1))
        End If
    Next
    '---restitution---
    .Cells(2, 3).Resize(n, 3) = resu
End With
End Sub

Sub Supprimer_doublons()
Dim d As Object, tablo, nn&, n&, i&, x, j%
Scinder 'lance la macro
Set d = CreateObject("Scripting.Dictionary")
With [A5].CurrentRegion.Resize(, 5)
    tablo = .Value 'matrice, plus rapide
    nn = UBound(tablo)
    n = 1
    For i = 2 To nn
        x = tablo(i, 5)
        If Not d.exists(x) Then
            d(x) = ""
            n = n + 1
            For j = 1 To 5
                tablo(n, j) = tablo(i, j)
            Next j
        End If
    Next i
    '---restitution---
    .Resize(n, 5) = tablo
    .Rows(1).Offset(n).Resize(Rows.Count - n - .Row + 1).Delete xlUp 'RAZ en dessous
    MsgBox IIf(nn > n, nn - n, "Aucune") & " ligne" & IIf(nn - n > 1, "s", "") & " supprimée" & IIf(nn - n > 1, "s", "")
End With
End Sub