Découper chaine de caractères

[mateo22]

Bonjour a vous Bonjour à vous,

J'ai un fichier de requêtes sur la colonne A

Je voudrais une macro qui découpe cette chaine des caractère sous une autre feuille
sans dépasser 70 caractères par nouvelle ligne créée et que chaque ligne finisse par une virgule.

Pour votre compréhension, un fichier est joint


Merci beaucoup de votre aide

Cordialement.

 

[job75]

Re : Découper chaine de caractères

Bonjour mateo22,

Je voudrais une macro qui découpe cette chaine des caractère sous une autre feuille
sans dépasser 70 caractères par nouvelle ligne créée (...)

Si l'on entre en B1 de la feuille souhait =NBCAR(A1) on trouve 73 caractères. Idem pour A5 (75) et A6 (72).

Que voulez-vous donc exactement 😕

A+

 

[mateo22]

Re : Découper chaine de caractères

Je l'ai fait manuellement

je voudrais que cela soit automatique

 

[MJ13]

Re : Découper chaine de caractères

Bonjour mateo, Job

Vu avec Henry (et \Données \convertir):

Pour 1 cellule, à adapter aux autres par recopie:

Sub Macro1()
'
' Macro1 Macro
'

'
    Selection.TextToColumns Destination:=ActiveCell.Offset(0, 1), DataType:=xlFixedWidth, _
        OtherChar:="'", FieldInfo:=Array(Array(0, 1), Array(70, 1), Array(140, 1), Array( _
        210, 1)) ', TrailingMinusNumbers:=True
End Sub

 

[job75]

Re : Découper chaine de caractères

Re, bonsoir Michel,

Voyez cette macro :

Sub DecoupeLigne()
Dim max%, lig&, cel As Range, txt$, c As Range, gauche%
With Sheets("découpe") 'à adapter
  max = 70 'modifiable
  lig = 1
  .[A:B].ClearContents
  For Each cel In Range("A1", [A65536].End(xlUp))
    txt = cel
1   Set c = .Cells(lig, 1)
    c = txt
    .Cells(lig, 2).FormulaR1C1 = "=LEN(RC1)" 'NBCAR facultatif
    If Len(c) > max Then
      gauche = InStrRev(Left(c, max), ",")
      txt = Right(c, Len(c) - gauche)
      c = Left(c, gauche)
      lig = lig + 1
      GoTo 1
    End If
    lig = lig + 1
  Next
  .Activate 'facultatif
End With
End Sub

Fichier joint.

A+

 

[MJ13]

Re : Découper chaine de caractères

Re

Job, en ce moment, on se croise 🙂.

Sinon mais cela est diffcile car cetains ont 69 et d'autres 70:

2 macros:

1 pour convertir en colonne (il faudra transformere de colonnes en lignes) et 1 pour convertir d'une selection vers la feuille 2.

Sub Converti_Texte_Colonne_70()
        For Each cell In Selection
        Selection.TextToColumns Destination:=ActiveCell.Offset(0, 1), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(70, 1), Array(140, 1), Array(Len(ActiveCell), 1))
        Next
End Sub

ou (plus abouti)​

Sub Converti_70_Selection_vers_Feuille2()
For Each cell In Selection
nbcar = Len(cell)
For i = 1 To Int(nbcar / 70) + 1
'Stop
derl = Sheets(2).Cells(65536, 1).End(xlUp).Row
If i = 1 Then Sheets(2).Cells(derl + 1, 1).Value = Mid(cell, 1, 70) Else Sheets(2).Cells(derl + 1, 1).Value = Mid(cell, (i - 1) * 70, 70)
Next
Next
End Sub

 

[ROGER2327]

Re : Découper chaine de caractères

Bonjour à tous

Sous réserve d'avoir tout deviné (Que doit-il advenir d'une chaîne comportant une section de plus de 69 caractères sans virgule ? Dans les exemples donnés, le découpage donne toujours trois chaînes pour une.: doit-il en être de même, avec éventuellement une ou deux lignes vides pour les chaînes courtes ?), voici une proposition :

Private Sub DECOUPE_Click()
  découpe_en_lignes_de_C_caractères C:=70
End Sub

Sub découpe_en_lignes_de_C_caractères(C%)
Dim i&, j&, o(), sDat$(), Tmp
  With Sheets("original") 'feuille de données
    o = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)).Value
  End With
  ReDim sDat(1 To 1)
  For i = 1 To UBound(o, 1) - 1
    If o(i, 1) <> "" Then '***
      Tmp = CL_C(CStr(o(i, 1)), C)
      For j = 0 To UBound(Tmp, 2)
        sDat(UBound(sDat)) = Tmp(0, j)
        ReDim Preserve sDat(1 To 1 + UBound(sDat))
      Next
    End If '***
  Next
  With Sheets("souhait") 'feuille de résultats
    .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)).ClearContents
    .Cells(1, 1).Resize(UBound(sDat), 1).Value = WorksheetFunction.Transpose(sDat)
  End With
End Sub

Private Function CL_C(rChn$, nCar%)
Dim i&, j%, k%, s$, t$(), x
  ReDim t(1, 0)
  If rChn <> "" Then
    s = Replace(rChn, ",", ",#")
    x = Split(s, "#")
    Do While i < UBound(x)
      ReDim Preserve t(1, j)
      Do While Len(t(0, j)) + Len(x(i)) <= WorksheetFunction.Max(nCar - 0, Len(x(i))) And i < UBound(x)
        t(0, j) = t(0, j) & x(i)
        i = i + 1
        k = j
      Loop
      j = j + 1
    Loop
    If Len(t(0, k)) + Len(x(UBound(x))) > nCar Then k = k + 1
    If i = UBound(x) Then ReDim Preserve t(1, k): t(0, k) = t(0, k) & x(UBound(x))
  End If
  CL_C = t
End Function

​

ROGER2327
#4906

Samedi 28 Décervelage 138 (Repopulation, V)
6 Pluviôse An CCXIX
2011-W04-2T00:25:22Z

 

[mateo22]

Re : Découper chaine de caractères

Merci a vous tous

Vous êtes vraiment très fort !!!!!

La solution de ROGER2327 me convient parfaitement

Probleme résolu