pas

Sub éclater()
Dim x, j&, k&, v$(), w$(), cel As Range
  With Selection
    If .Columns.Count = 1 Then
      For Each cel In .Cells
        x = Split(CStr(cel.Value), ",")
        For j = 0 To UBound(x)
          If Trim(x(j)) <> "" Then k = k + 1: ReDim Preserve v(1 To k): v(k) = Trim(x(j))
        Next j
      Next cel
      If k > 0 Then
        ReDim w(1 To k, 0)
        For j = 1 To k: w(j, 0) = v(j): Next j
        With .Resize(k, 1)
          .Value = w
          .RemoveDuplicates Columns:=1, Header:=xlNo

'=====   Pour traduire en français lisible :   ====='

          .CheckSpelling SpellLang:=1036
          .RemoveDuplicates Columns:=1, Header:=xlNo

'==================================================='

          .Cells(1).Select
        End With
      End If
    End If
  End With
End Sub

Sub éclater2() 'Plus rapide. Conseillé si les données sont nombreuses.
Dim x, i&, j&, k&, u(), v$(), w$()
  With Selection
    If .Columns.Count = 1 Then
      u = .Resize(.Rows.Count, 2).Value
      ReDim Preserve u(1 To UBound(u), 1 To 1)
      For i = 1 To UBound(u)
        x = Split(u(i, 1), ",")
        For j = 0 To UBound(x)
          If Trim(x(j)) <> "" Then k = k + 1: ReDim Preserve v(1 To k): v(k) = Trim(x(j))
        Next j
      Next i
      If k > 0 Then
        ReDim w(1 To k, 0)
        For j = 1 To k: w(j, 0) = v(j): Next j
        With .Resize(k, 1)
          .Value = w
          .RemoveDuplicates Columns:=1, Header:=xlNo

'=====   Pour traduire en français lisible :   ====='

          .CheckSpelling SpellLang:=1036
          .RemoveDuplicates Columns:=1, Header:=xlNo

'==================================================='

          .Cells(1).Select
        End With
      End If
    End If
  End With
End Sub