Eclater le contenu d'une cellule en ligne

Bonjour à tous,

Je cherche une solution pour éclater le contenu d'une cellule contenant des chaines de caractère séparés par des ";", en ligne les uns sous les autres dans la même colonne.

Je souhaiterais que cela se produise sur toutes les lignes les unes après les autres, en créant le décalage qu'il faut pour ne pas effacer la donnée des lignes en dessous. Pas besoin de recopier les autres colonnes adjacentes par contre.

Je vous mets en PJ un exemple illustré.

Ci-plus loin, des exemples de macros utilisés par le passé sur ce dilemme

Zoul67

Sub essai()

    While InStr(1, ActiveCell.Value, Chr(10)) > 0
        saut = InStr(1, ActiveCell.Value, Chr(10))
        gauche = Left(ActiveCell.Value, saut - 1)
        droite = Mid(ActiveCell.Value, saut + 1)
        r = MsgBox("Voulez-vous créer une nouvelle ligne :" & Chr(10) & gauche & "?", vbYesNo)
        If r = vbYes Then
            ActiveCell.Value = gauche
            ActiveCell.Offset(1, 0).EntireRow.Insert
            ActiveCell.Offset(1, 0).Value = droite
            For c = 1 To 10
                If c <> 8 Then Cells(ActiveCell.Row + 1, c).Value = Cells(ActiveCell.Row, c).Value
            Next c
            ActiveCell.Offset(1, 0).Select
        Else
            ActiveCell.Value = gauche & Chr(13) & droite
        End If
    Wend
End Sub

VIA55

Sub decompose()
Dim a(10) ' nombre maxi de tâches à décomposer - peut être augmenté si nécessaire
texte = Sheets(1).Range("B1").Value ' Le texte à décomposer se trouve en B1 de la 1ere feuille (à adapter à ton fichier)
'reperage de tous les [
For n = 6 To Len(texte)
If Mid(texte, n, 1) = "[" Then x = x + 1: a(x) = n
Next
' extraction de la 1ere tâche
partie = Mid(texte, 6, a(1) - 6)
Range("A1").Value = partie
'extraction de la 2nde à l'avant dernière tâche
For t = 2 To x - 1
partie = Mid(texte, a(t) + 5, a(t + 1) - a(t) - 5)
Range("A" & t).Value = partie
Next
'extraction de la dernière tâche
partie = Mid(texte, a(x) + 5, Len(texte) - a(x) - 5)
Range("A" & x).Value = partie
End Sub 

Merci par avance pour votre aide,

Cdt,

G.

Bonjour Pwetzou

Vois ceci :

Restitution à côté du tableau initial.

Option Explicit

Sub test()
Dim a, b(), i As Long, j As Long, x, n As Long
    With Sheets("Feuil1").Range("a2").CurrentRegion
        a = .Value
        'attention à la 1ère dimension
        ReDim b(1 To UBound(a, 1) * 10, 1 To UBound(a, 2))
        For i = 1 To UBound(a, 1)
            x = Split(a(i, 6), ";")
            For j = 0 To UBound(x)
                n = n + 1
                If j = 0 Then
                    b(n, 1) = a(i, 1): b(n, 2) = a(i, 2)
                    b(n, 3) = a(i, 3): b(n, 4) = a(i, 4)
                    b(n, 5) = a(i, 5): b(n, 7) = a(i, 7)
                    b(n, 8) = a(i, 8)
                End If
                b(n, 6) = x(j)
            Next
        Next
        .Offset(, .Columns.Count + 1).Resize(n).Value = b
    End With
End Sub

klin89

Waw..

Merci beaucoup, ça dépote.

Tu crois qu'il y a une solution pour mettre un remplissage où un trait très épais entre les "packs" en ligne ? pour dissocier les éléments visuellement.

Code adapté sur 15 colonnes :

Sub test()
Dim a, b(), i As Long, j As Long, x, n As Long
    With Sheets("Feuil1").Range("a2").CurrentRegion 'définition du point de départ du tableau à traiter avec current region
        a = .Value
        'attention à la 1ère dimension
       ReDim b(1 To UBound(a, 1) * 10, 1 To UBound(a, 2))
        For i = 1 To UBound(a, 1)
            x = Split(a(i, 6), ";") '6 c'est le n° de la colonne de la cellule à éclater
            For j = 0 To UBound(x)
                n = n + 1
                If j = 0 Then 'ici définir le nombre de colonnes à recopier avec mais en laissant vide (espace à mettre à côté des cellules recopiées et éclatées)
                    b(n, 1) = a(i, 1): b(n, 2) = a(i, 2)
                    b(n, 3) = a(i, 3): b(n, 4) = a(i, 4)
                    b(n, 5) = a(i, 5): b(n, 7) = a(i, 7)
                    b(n, 8) = a(i, 8): b(n, 9) = a(i, 9)
                    b(n, 10) = a(i, 10): b(n, 11) = a(i, 11)
                    b(n, 12) = a(i, 12): b(n, 13) = a(i, 13)
                    b(n, 14) = a(i, 14): b(n, 15) = a(i, 15)

                End If
                b(n, 6) = x(j)
            Next
        Next
        .Offset(, .Columns.Count + 1).Resize(n).Value = b
    End With
End Sub

Re Pwetzou,

Pour la mise en forme :

Sub test()
    Dim myArea As Range
    'mise en forme
    With Sheets("Feuil1").Range("a14").CurrentRegion
        .Borders.LineStyle = xlNone
        For Each myArea In .Columns(1).SpecialCells(2).Areas
            myArea.Resize(, 8).BorderAround Weight:=xlMedium
        Next
        For Each myArea In .Columns(1).SpecialCells(4).Areas
            myArea.Offset(, 5).BorderAround Weight:=xlMedium
            myArea.Offset(, 5).Borders(xlInsideHorizontal).Weight = xlMedium
        Next
    End With
End Sub

klin89

Merci beaucoup !