Fractionner une cellule en plusieurs lignes

Bonjour,

j'ai besoin d'un génie :

je voudrais faire ça ( voir tableau ) automatiquement ( 1000 lignes )

en :

ce que je voudrais c'est de diviser la colonne 3 en plusieurs lignes en fonctions du nombre de lignes qu'il y a dans la cellule.

Merci

Bonjour et bienvenue sur le forum

Tu devrais nous montrer ça sur un fichier joint à ton post.

Bye !

Bonjour

Un essai à tester. Te convient-il ?

Option Explicit

Dim tablo, tabloR(), f3 As Worksheet
Dim i&, j&, k&, n&, nb&, d&, f&, derln&

Sub Fractionner()

    tablo = Range("A1:J" & Range("A" & Rows.Count).End(xlUp).Row)
    Set f3 = Sheets("Feuil3")
    k = 0
    For i = 1 To UBound(tablo, 1)
        nb = UBound(Split(tablo(i, 8), Chr(10)))
        For n = 0 To nb
            ReDim Preserve tabloR(1 To 10, 1 To nb + 1 + k)
            For j = 1 To 10
                On Error Resume Next
                tabloR(j, 1 + n + k) = Split(tablo(i, j), Chr(10))(n)
            Next j
        Next n
        k = k + nb + 1
    Next i
    f3.Cells.Clear
    f3.Range("A1").Resize(UBound(tabloR, 2), UBound(tablo, 2)) = Application.Transpose(tabloR)

    d = 1
    derln = f3.Range("H" & Rows.Count).End(xlUp).Row
    For i = 1 To f3.Range("H" & Rows.Count).End(xlUp).Row
        If (f3.Range("A" & i) <> "" And i <> d) Or i = derln Then
            f = i - 1
            For j = 1 To 10
                If j <> 8 Then
                    With f3.Range(f3.Cells(d, j), f3.Cells(f, j))
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .Merge
                    End With
                End If
            Next j
            d = i
        End If
    Next i
    f3.Activate
End Sub

Bye