Scinder une cellule en deux colonnes si plus de 40 caractères

Bonjour à tous,

J'aurais besoin de scinder une cellule en deux colonnes, chaque colonne ne peut contenir plus de 40 caractères et je voudrais que la scission se fasse entre deux mots pour ne pas le couper en deux. Si la deuxième colonne devait contenir plus de 40 caractères, ce qui est en surplus sera perdu.

En fouillant le net, j'ai trouvé un code qui est presque ce que je voudrais, sauf qu'au lieu de scinder en deux colonnes, ça le scinde en deux lignes et qu'il crée autant de ligne qu'il faut pour scinder la cellule.

Sub Demo()
    AR = Range("A1", Cells(Rows.Count, 1).End(xlUp)).Value

    For r& = 1 To UBound(AR)
        L& = Len(AR(r, 1))

        If L Then
            C& = 0:  P& = 0

            Do While L - P > 40
                P = InStrRev(AR(r, 1), " ", P + 40)
                If P > C Then Mid(AR(r, 1), P, 1) = "¤": A& = A& + 1: C = P Else Exit Do
            Loop
        End If
    Next

    ReDim TR$(1 To UBound(AR) + A, 1 To 1)

    For Each V In AR
        If V > "" Then
            For Each S In Split(V, "¤")
                N& = N& + 1:  TR(N, 1) = S
            Next

        Else
            N = N + 1
        End If
    Next

    [A1].Resize(UBound(TR)).Value = TR
End Sub

Je débute dans VBA et là, ça me dépasse

D'avance merci pour votre aide.

Bonjour et bienvenue Alister,

Voici un code à essayer:

Sub test()
    Dim t, t1(), txt

        With ActiveSheet
            t = .Range("A1").CurrentRegion
            ReDim t1(UBound(t, 1), 1)

            For i = LBound(t, 1) To UBound(t, 1)
                txt = Split(t(i, 1), " ")
                For j = LBound(txt) To UBound(txt)
                    If Len(t1(i, 0)) + Len(txt(j)) <= 40 Then
                        t1(i, 0) = Trim(t1(i, 0)) & " " & txt(j)
                    Else
                        If Len(t1(i, 1)) + Len(txt(j)) <= 40 Then t1(i, 1) = Trim(t1(i, 1)) & " " & txt(j)
                    End If
                Next j
            Next i

            .Columns(2).Resize(, UBound(t1, 2)).ClearContents
            .Range("B1").Resize(UBound(t1, 1) + 1, UBound(t1, 2) + 1) = t1
        End With

End Sub

Bonjour le fil, bonjour le forum,

Un autre code Full Comment :

Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim K As Integer 'déclare la variable K (incrément)
Dim I As Integer 'déclare la variable I (Incrément)
Dim LT As Integer 'déclare la variable LT (Longueur Totale)
Dim PP As String 'déclare la variable PP (Première Partie)
Dim DE As Byte 'déclare la variable DE (Dernier Espace)
Dim SP As String 'déclare la variable SP (Seconde Partie)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)

Set O = Worksheets("Feuil1") 'définit l'onglet O (à adapter)
TV = O.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
K = 1 'initialise la variable K
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs (en partant de la seconde)
    LT = Len(TV(I, 1)) 'définit la longueur totale de la donnée en ligne I colonne 1 de TV
    If LT > 40 Then 'condition : si LT est supérieure à 40
        PP = Left(TV(I, 1), 40) 'définit la première partie PP (les 40 premiers caractères)
        DE = InStrRev(PP, " ", -1, vbTextCompare) 'définit la position du dernier espace de PP
        PP = Left(TV(I, 1), DE - 1) 'redéfinit la première partie PP (du premier au caractère jusu'a 1 caractère avant DE) / le dernier espace est supprimé
        SP = Mid(TV(I, 1), DE + 1, 40) 'définit la seconde partie SP (les 40 derniers caractères après DE + 1) / le premier espace est supprimé
    Else 'sinon
        PP = TV(I, 1) 'définit la première partie PP
        SP = "" 'définit la seconde partie SP
    End If 'fin de la condition
    ReDim Preserve TL(1 To 2, 1 To K) 'redimensionne le tableau des lignes TL (2 lignes, K colonnes)
    TL(1, K) = PP 'récupère la première partie dans la ligne 1 de TL
    TL(2, K) = SP 'récupère la seconde partie dans la ligne 2 de TL
    K = K + 1 'incrémente K (ajoute une colonne au talbleau des lignes TL)
Next I 'prochaine ligne de la boucle
'si K est supérieure à 1, renvoie dans C1 redimensionnée le tableau TL transposé
If K > 1 Then O.Range("C2").Resize(UBound(TL, 2), 2).Value = Application.Transpose(TL)
End Sub

@Florian53 : Merci mais ça ne fait pas encore ce que je veux, il déplace des mots.

Voici un exemple ce que ca donne :

Ce texte :

Un texte qui fait bien plus de 40 caractères et qui devrait donc être coupés en deux colonnes

Donne :

Un texte qui fait bien plus de 40 et qui (Dans la première colonne)

caractères devrait donc être coupés en (Dans la deuxième colonne)

@ThauThème : C'est parfaitement ce que je cherchais

Merci à tous les deux de vous être penché sur mon problème !!

Voici une modif pour répondre à ta demande:

Sub test()
    Dim t, t1(), txt

        With ActiveSheet
            t = .Range("A1").CurrentRegion
            ReDim t1(UBound(t, 1), 1)

            For i = LBound(t, 1) To UBound(t, 1)
                txt = Split(t(i, 1), " ")
                For j = LBound(txt) To UBound(txt)
                    If Len(t1(i, 0)) + Len(txt(j)) <= 40 Then
                        t1(i, 0) = Trim(t1(i, 0)) & " " & txt(j)
                    Else
                        If Len(t1(i, 1)) + Len(txt(j)) <= 40 Then t1(i, 1) = Trim(t1(i, 1)) & " " & txt(j)
                    End If
                Next j
            Next i

            .Columns(1).Resize(, UBound(t1, 2)).ClearContents
            .Range("A1").Resize(UBound(t1, 1) + 1, UBound(t1, 2) + 1) = t1
        End With

End Sub

Ca donne la même chose mais pas aux mêmes cellules. Mais sinon, j'ai eu ma solution avec @ThauThème. C'est gentil d'avoir cherché pour mon problème en tout cas !

Je te souhaite une bonne fin de journée