Cas: Comment sortir plusieurs valeurs d'une celulle

[thony_443]

Bonjour à tous 😀

J'ai un cas pratique que je n'arrive pas à résoudre et qui s'avère être très chronophage sans une maîtrise des macros,

Je souhaite sortir les différentes valeurs présentes dans une celllule, et les placer chacunes dans une cellule qui lui est propre.

J'ai concoctais un fichier excel reprenant le cas,
Si quelqu'un à la réponse et le temps de ce pencher sur ce cas, je lui serais extrêmemnt reconnaissant --> le temps gagné serait énorme !

Informations:

- Les valeurs dans la colonne "options" sont toutes séparées d'une "," suivi d'un espace
- cf la feuille "Résultat attendu", est il possible de séparer les options, les placer à la verticale avec en face la valeur correspondante ?
- il existe N nombre de valeur
- le nombre d'option peut varier selon la valeur

Je vous remercie par avance pour votre retour !

 

[DoubleZero]

Re : Cas: Comment sortir plusieurs valeurs d'une celulle

Bonjour à toutes et à tous,

...Je vous remercie par avance pour votre retour !

Un retour d'ici 🙄 serait appréciable.

 

[job75]

Re : Cas: Comment sortir plusieurs valeurs d'une celulle

Bonjour thony_443, DoubleZero 🙂

Voyez le fichier joint avec cette macro :

Sub Eclatement()
Dim sep$, t, i&, x, s, ub%, a(), n&, j%, resu()
sep = ", "
t = [A1].CurrentRegion.Resize(, 2)
For i = 1 To UBound(t)
  If t(i, 2) <> "" Then
    x = t(i, 1)
    s = Split(t(i, 2), sep)
    ub = UBound(s)
    ReDim Preserve a(1, n + ub)
    For j = 0 To ub
      a(0, n + j) = x
      a(1, n + j) = s(j)
    Next
    n = n + ub + 1
  End If
Next
If n = 0 Then Exit Sub
'---transposition---
ReDim resu(n - 1, 1)
For i = 0 To n - 1
  For j = 0 To 1
    resu(i, j) = a(j, i)
  Next
Next
'---restitution---
With Sheets("Résultat")
  .[A:B].ClearContents
  .[A1].Resize(n, 2) = resu
  .Activate
End With
End Sub

A+

 

[job75]

Re : Cas: Comment sortir plusieurs valeurs d'une celulle

Re,

La macro précédente supprime les lignes dont la cellule en colonne B est vide.

Si l'on veut cependant les conserver utiliser :

Sub Eclatement()
Dim sep$, t, i&, x, s, ub%, a(), n&, j%, resu()
sep = ", "
t = [A1].CurrentRegion.Resize(, 2)
For i = 1 To UBound(t)
  If t(i, 2) = "" Then
    ReDim Preserve a(1, n)
    a(0, n) = t(i, 1)
    n = n + 1
  Else
    x = t(i, 1)
    s = Split(t(i, 2), sep)
    ub = UBound(s)
    ReDim Preserve a(1, n + ub)
    For j = 0 To ub
      a(0, n + j) = x
      a(1, n + j) = s(j)
    Next
    n = n + ub + 1
  End If
Next
'---transposition---
ReDim resu(n - 1, 1)
For i = 0 To n - 1
  For j = 0 To 1
    resu(i, j) = a(j, i)
  Next
Next
'---restitution---
With Sheets("Résultat")
  .[A:B].ClearContents
  .[A1].Resize(n, 2) = resu
  .Activate
End With
End Sub

Fichier (2).

A+

 

[DoubleZero]

Re : Cas: Comment sortir plusieurs valeurs d'une celulle

Re-bonjour,

Un petit retour pour un grand b😀nj😀ur à j😀b75.

A bientôt 🙂

 

[klin89]

Re : Cas: Comment sortir plusieurs valeurs d'une celulle

Bonsoir DoubleZero, job75, thony_443, le forum

A tester :

Sub Transpose()
Dim a, b, e, txt As String, i As Long, n As Long, x As Long
    With Range("a1").CurrentRegion
        txt = Join$(Application.Transpose(.Columns(2).Value))
        x = Len(txt)
        a = .Value
        ReDim b(1 To x, 1 To 2)
        For i = 1 To UBound(a, 1)
            n = n + 1
            'b(n, 1) = a(i, 1)
            For Each e In Split(a(i, 2), ",")
                b(n, 1) = a(i, 1)
                b(n, 2) = Trim$(e)
                n = n + 1
            Next
            n = n - 1
        Next
        With .Offset(, .Columns.Count + 2).Resize(n)
            .CurrentRegion.Clear
            .Value = b
        End With
    End With
End Sub

klin89

 

[job75]

Re : Cas: Comment sortir plusieurs valeurs d'une celulle

Bonjour le fil, le forum,

klin89 a raison, redimensionner le tableau a chaque ligne augmente un peu la durée d'exécution.

La solution la plus rapide est de donner au tableau le nombre de lignes de la feuille de calcul :

Sub Eclatement()
Dim sep$, t, resu(), i&, n&, x, s, ub%, j%
sep = ", "
t = [A1].CurrentRegion.Resize(, 2)
ReDim resu(Sheets("Résultat").Rows.Count - 1, 1)
For i = 1 To UBound(t)
  If t(i, 2) = "" Then
    resu(n, 0) = t(i, 1)
    n = n + 1
  Else
    x = t(i, 1)
    s = Split(t(i, 2), sep)
    ub = UBound(s)
    For j = 0 To ub
      resu(n + j, 0) = x
      resu(n + j, 1) = s(j)
    Next
    n = n + ub + 1
  End If
Next
'---restitution---
With Sheets("Résultat")
  .[A:B].ClearContents
  .[A1].Resize(n, 2) = resu
  .Activate
End With
End Sub

Fichier (3).

A+

 

[thony_443]

Re : Cas: Comment sortir plusieurs valeurs d'une celulle

Merci à vous pour vos réponses !

Vous m'avez fait gagner un temps précieux !

A bientôt !

😀

 

[gosselien]

Re : Cas: Comment sortir plusieurs valeurs d'une celulle

Bonjour le forum et job75,

j'ai essayé ton code... bien fait et rapide et pourrait m'être utile aussi
Bravo

P.