partager un texte dans des cellules

[Ilino]

Bonsoir Forum
Je souhaite élaborer un code qui revoie le reste du texte d’une cellule a l’autre
Exemple dans la feuille 1 Je saisi un texte dans une cellule A1 :
« Salut MAITRE, je cherche à créer une Macro qui renvoie le texte d’une cellule à l’autre. »
Dans la feuille2 je souhaite partage le texte vers ces deux cellules X15 et A16
X15-AG15 (cellule fusionnée) et le reste du texte A16-R16 (cellule fusionnés)
A+

 

[job75]

Re : partager un texte dans des cellules

Bonsoir Ilino,

Voici la macro :

Sub PartageTexte()
Dim source$, dest1 As Range, dest2 As Range, h#, s, i%, x%
'---données---
source = Application.Trim(Feuil1.[A1].Text)
If source = "" Then Exit Sub
Set dest1 = Feuil2.[X15:AG15]
Set dest2 = Feuil2.[A16]
'---préparation---
dest1.UnMerge 'défusion
dest1.HorizontalAlignment = xlCenterAcrossSelection
dest1.WrapText = True 'retour à la ligne
dest1.Rows.AutoFit 'ajustement automatique
h = dest1.RowHeight 'hauteur de ligne initiale
s = Split(source) 'matrice des mots
'---remplissage de dest1---
For i = 1 To UBound(s)
  x = Len(s(0)) 'mémorisation
  s(0) = s(0) & " " & s(i)
  dest1(1) = s(0)
  dest1.Rows.AutoFit
  If dest1.RowHeight > h Then Exit For
Next
If i > UBound(s) Then x = Len(source)
dest1(1) = Left(source, x)
dest1.RowHeight = h
dest1.Merge 'refusion
dest1.HorizontalAlignment = xlGeneral
'---remplissage de dest2---
dest2 = Mid(source, x + 2)
End Sub

Edit : ajouté If i > UBound(s) Then...

Bonne nuit et A+

 

[Ilino]

Re : partager un texte dans des cellules

Re
c'est nickel c'est extra .... PBLM RESOLUT
bonne nuit MAITRE et B.W
A+

 

[job75]

Re : partager un texte dans des cellules

Bonjour Ilino,

On peut vouloir ajuster le nombre de cellules fusionnées de la 2ème plage dest2 :

Sub PartageTexte1()
Dim source$, dest1 As Range, dest2 As Range, h#, s, i%, x%
'---données---
source = Application.Trim(Feuil1.[A1].Text)
If source = "" Then Exit Sub
Set dest1 = Feuil2.[X15:AG15]
Set dest2 = Feuil2.[A16]
'---préparation de dest1---
Application.ScreenUpdating = False
dest1.UnMerge 'défusion
dest1.HorizontalAlignment = xlCenterAcrossSelection
dest1.WrapText = True 'retour à la ligne
dest1.Rows.AutoFit 'ajustement automatique
h = dest1.RowHeight 'hauteur de ligne initiale
s = Split(source) 'matrice des mots
'---remplissage de dest1---
For i = 1 To UBound(s)
  x = Len(s(0)) 'mémorisation
  s(0) = s(0) & " " & s(i)
  dest1(1) = s(0)
  dest1.Rows.AutoFit
  If dest1.RowHeight > h Then Exit For
Next
If i > UBound(s) Then x = Len(source)
dest1(1) = Left(source, x)
dest1.RowHeight = h
dest1.Merge 'refusion
dest1.HorizontalAlignment = xlGeneral
'---préparation de dest2---
dest2 = ""
dest2.UnMerge 'défusion
dest2.WrapText = True
dest2.Rows.AutoFit
h = dest2.RowHeight
'---remplissage et ajustement de dest2---
dest2 = Mid(source, x + 2)
i = 1
While dest2.RowHeight > h
  i = i + 1
  Set dest2 = dest2.Resize(, i)
  dest2(, i).UnMerge 'au cas où...
  dest2(, i) = ""
  dest2.HorizontalAlignment = xlCenterAcrossSelection
  dest2.Rows.AutoFit
Wend
dest2.Merge 'refusion
dest2.HorizontalAlignment = xlGeneral
End Sub

Bonne journée.

 

[Ilino]

Re : partager un texte dans des cellules

Bonsoir JOB
GRAZIE encore pour tes propositions, c'est nickel
Bonne nuit MAITRE
A+