(erreur et méprise) Répartir du texte dans une colonne

[hemardjean]

Bonjour le forum bonjour a tous

« Petite méprise et pardon a phlaurent son code marche mais il ne coupe pas les mots j’ai rompu le post trop vite»

Donc je repose ma question :
Je suis cuisinier et je prends des recettes sur internet .Pour les copier de la page j’utilise la fonction dans la liste exporter vers Microsoft Excel. Celle-ci est copiée dans une nouvelle feuille en colonne A.

Je fais un copier/coller de ce texte que je place dans la colonne A et dans la cellule 5 de largeur 35 (largeur qui ne doit pas changer) dans une fiche technique que j’ai créé.

Ma question est :

Le texte copier sur le net (réparti sur plusieurs cellules en colonne A)est trop long. Peut-on couper le texte pour n’avoir que 35 caractères par cellule (maximum que je peux placer) et faire se succéder dans celle du dessous le reste du texte uniquement dans la colonne A .

Le code de phlaurent et le suivant

Sub Macro1()
Range("A24:A" & Range("A65535").End(xlUp).Row).Select
With Selection
.WrapText = True
End With
Selection.Rows.AutoFit
End Sub

Pour plus de compréhension je vous joins une partie du fichier.

Merci à vous Cordialement A+

 

[jp14]

Re : (erreur et méprise) Répartir du texte dans une colonne

Bonjour

Ci dessous une macro qui découpe le texte pour n’avoir que 35 caractères par cellule.

A tester

Sub travdem()
Dim Cellule As Range
Dim Nomfeuille1 As String
Dim Col As String
Dim I As Long, dl1 As Long
Dim Nbc As Long, J As Long
Dim Nbcel As Double
Dim Data1 As String
Dim val1 As Long
'parametre
Nomfeuille1 = "fiche donne"
Col = "A"

With Sheets(Nomfeuille1)

dl1 = .Range(Col & .Rows.Count).End(xlUp).Row

For I = dl1 To 1 Step -1
    Data1 = .Range("A" & I)
    Nbc = Len(Data1)
    If Nbc > 35 Then
        Nbcel = Application.WorksheetFunction.RoundUp(Nbc / 35, 0)
        For J = 0 To Nbcel - 2
            Rows(I + 1).Insert Shift:=xlDown
        Next J
        
        For J = 0 To Nbcel - 1
            val1 = J * 35
            If val1 = 0 Then val1 = 1
            .Range("A" & I + J) = Mid(Data1, val1, 35)
        Next J
    End If
Next I

Pour éviter de couper un mot, j'ai modifié la procédure ci dessus.

Sub travdem()
Dim Cellule As Range
Dim Nomfeuille1 As String
Dim Col As String
Dim I As Long, dl1 As Long, Nbc As Long, J As Long, J1 As Byte, J2 As Long

Dim tablo1() As String
Dim tablo2() As String
Dim Nbcel As Double
Dim Data1 As String, Data2 As String, data3 As String
Dim val1 As Long
'parametre
Nomfeuille1 = "fiche donne"
Col = "A"

With Sheets(Nomfeuille1)

dl1 = .Range(Col & .Rows.Count).End(xlUp).Row

For I = dl1 To 5 Step -1
    Data1 = .Range("A" & I)
    If Len(Data1) > 35 Then
        'Data1=
        tablo1 = Split(Data1, " ")
        ReDim tablo2(0 To UBound(tablo1) + 1)
        J2 = 0
        Data2 = ""
        For J = LBound(tablo1) To UBound(tablo1)
            J1 = 0
            Do
                If Len(Data2) < 34 Then
                    data3 = Data2
                    Data2 = Trim(Data2 & " " & tablo1(J + J1))
                    J1 = J1 + 1
                End If
                
                If Len(Data2) >= 34 Then
                    Data2 = data3
                    J = J + J1 - 2
                    Exit Do
                End If
                
                If (J + J1 - 1) >= UBound(tablo1) Then
                    Exit Do
                End If
            Loop
            tablo2(J2) = Data2 & " "
            J2 = J2 + 1
            Data2 = ""
        Next J
        
        For J = 0 To J2 - 2
                Rows(I + 1).Insert Shift:=xlDown
        Next J
        For J = 0 To J2 - 1
            .Range("A" & I + J) = tablo2(J)
        Next J
    End If
Next I

End With
End Sub

JP

 

[hemardjean]

Re : (erreur et méprise) Répartir du texte dans une colonne

Bonjour JP et le forum
Merci pour ta réponse et toutes mes excuses pour mon retard. Ton code fonctionne très bien mais pourrez t-il ne travailler que dans la colonne A car j’ai des liste déroulantes en face .
Merci JP
Cordialement A+

 

[jp14]

Re : (erreur et méprise) Répartir du texte dans une colonne

Bonjour

Il faut modifier le code suivant
For J = 0 To J2 - 2
Rows(I + 1).Insert Shift:=xlDown
Next J

et mettre à la place

For J = 0 To J2 - 2
.Range("a" & (I + 1)).Insert Shift:=xlDown
Next J
JP

 

[hemardjean]

Re : (erreur et méprise) Répartir du texte dans une colonne

Bonsoir JP et le forum

Encore un petit problème les dernières phrases coupées de chaque cellules se répètent plusieurs fois.

Cordialement A+

 

[jp14]

Re : (erreur et méprise) Répartir du texte dans une colonne

Bonsoir

Ci joint la procédure modifiée.
Il y avait un problème au niveau de la sortir de la boucle for next

Sub travdem()
Dim Cellule As Range
Dim Nomfeuille1 As String
Dim Col As String
Dim I As Long, dl1 As Long, Nbc As Long, J As Long, J1 As Byte, J2 As Long

Dim Tablo1() As String
Dim Tablo2() As String
Dim Nbcel As Double
Dim Data1 As String, Data2 As String, data3 As String
Dim Val1 As Long
Dim Total As Long
Dim Nbcar As Long
'parametre
Nomfeuille1 = "fiche donne"
Col = "A"

With Sheets(Nomfeuille1)

dl1 = .Range(Col & .Rows.Count).End(xlUp).Row

For I = dl1 To 5 Step -1
    Data1 = .Range("A" & I)
    Nbcar = Len(Data1)
    If Nbcar > 35 Then
        'Data1=
        Tablo1 = Split(Data1, " ")
        ReDim Tablo2(0 To UBound(Tablo1) + 1)
        J2 = 0
        Data2 = ""
        Total = 0
        For J = LBound(Tablo1) To UBound(Tablo1)
            J1 = 0
            Do
                If Len(Data2) < 34 Then
                    data3 = Data2
                    Data2 = Trim(Data2 & " " & Tablo1(J + J1))
                    J1 = J1 + 1
                End If
                
                If Len(Data2) >= 34 Then
                    Data2 = data3
                    J = J + J1 - 2
                    Exit Do
                End If
                
                If (J + J1 - 1) >= UBound(Tablo1) Then
                    J = J + J1
                    Exit Do
                End If
            Loop
            Tablo2(J2) = Data2 & " "
            Total = Total + Len(Tablo2(J2))
            J2 = J2 + 1
            Data2 = ""
            If Total >= Nbcar Then Exit For
        Next J
        
        For J = 0 To J2 - 2
                .Range("a" & (I + 1)).Insert Shift:=xlDown
        Next J
        For J = 0 To J2 - 1
            .Range("A" & I + J) = Tablo2(J)
        Next J
    End If
Next I

End With
End Sub

A tester

JP

 

[hemardjean]

Re : (erreur et méprise) Répartir du texte dans une colonne

Bonjour JP et le forum

Bravo et encore merci pour ce code il fonctionne très bien dans mon dossier. Peut tu m’expliquer quel chiffre il faut changer pour augmenter le nombre de mots coupés pour que je l’adapte a la largeur de ma cellule je ferai les réglages.

Cordialement
hemardjean

 

[jp14]

Re : (erreur et méprise) Répartir du texte dans une colonne

Bonjour

Pour modifier le nombre de caractères, il faut changer les valeurs suivante

If Nbcar > 35 Then
       ..............................
                If Len(Data2) >= 34 Then
                    Data2 = data3

35 nombre maximal dans une ligne
et
34 qui correspond à 35 moins le caractère espace que l'on rajoute par le code suivant (Tablo2(J2) = Data2 & " ".)

JP

 

[hemardjean]

Re : (erreur et méprise) Répartir du texte dans une colonne

Bonsoir JP et le forum

Merci encore une très bonne journée et peut-être à plus tard

Cordialement A+ hemardjean