Renvoie a la ligne automatiquement dans des cellules Fusionnées (vba)

[Ilino]

Bonsoir Forum
je souhaiterai avoir le code qui me permets de renvoyer le texte a la ligne automatiquement dans les cellules fusionnées.
ci joint mon fichier
les cellules concernées sont en rouge
Grazie
NB: j'ai déjà un code dans mon fichier ( module 2) mais il est très lent😕
Merci a Job

 

[Ilino]

Re : Renvoie a la ligne automatiquement dans des cellules Fusionnées (vba)

Bonsoir Forum
est ce que mon souci est potentiel ?
GRAZIE

 

[job75]

Re : Renvoie a la ligne automatiquement dans des cellules Fusionnées (vba)

Bonjour Ilino,

Il faut savoir que dans une cellule fusionnée la commande "Ajuster la hauteur de ligne" ne fonctionne pas.

Pour voir les renvois à la ligne il faut donc modifier manuellement la hauteur de ligne.

VBA n'apporte rien.

C'est comme ça 🙂

A+

 

[job75]

Re : Renvoie a la ligne automatiquement dans des cellules Fusionnées (vba)

Re,

Cela dit on peut ruser en :

- défusionnant les cellules

- les centrant sur plusieurs colonnes

- ajustant la hauteur de ligne

- refusionnant.

Voir cette macro dans le fichier joint :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim t As Range, r1 As Range, r2 As Range, h As Double
Set t = Intersect(Target, [B14:Q40,AE14:AM40]) 'à adapter
If t Is Nothing Then Exit Sub
Application.ScreenUpdating = False
For Each t In t ' si plusieurs cellules sont modifiées
  Set r1 = Intersect(t.EntireRow, [B:Q])
  Set r2 = Intersect(t.EntireRow, [AE:AM])
  Union(r1, r2).UnMerge 'défusionne
  r1.HorizontalAlignment = xlCenterAcrossSelection
  r2.HorizontalAlignment = xlCenterAcrossSelection
  r1.Rows.AutoFit 'ajustement automatiquement
  h = r1.Rows.Height 'mémorise la hauteur
  r1.Merge: r2.Merge 'refusionne
  Union(r1, r2).HorizontalAlignment = xlGeneral
  If h < 409 Then r1.RowHeight = h 'hauteur de ligne
Next
End Sub

A+

 

[mapomme]

Re : Renvoie a la ligne automatiquement dans des cellules Fusionnées (vba)

Bonjour Ilino 🙂, job75 😀

Une autre façon, sans défusionner, mais avec une cellule auxiliaire.

Le code (dans module2):

Sub TEST()
  Hauteur Sheets("chalet").Range("b14:ae40")
End Sub

Sub Hauteur(MaSelection As Range)
Dim i As Long, j As Long, xcell As Range, xAux As Range
Dim LigDeb As Long, LigFin As Long, ColDeb As Long, ColFin As Long
Dim HauteurDef As Single, Largeur As Single

Application.ScreenUpdating = False
LigDeb = MaSelection.Row
LigFin = MaSelection.Row + MaSelection.Rows.Count - 1
ColDeb = MaSelection.Column
ColFin = MaSelection.Column + MaSelection.Columns.Count - 1

With Sheets(MaSelection.Parent.Name)
Set xAux = .Cells(.Rows.Count, .Columns.Count)
For i = LigDeb To LigFin
  .Cells(i, 1).EntireRow.RowHeight = 3
  For j = ColDeb To ColFin
    If .Cells(i, j).MergeCells Then
      If .Cells(i, j).Address = .Cells(i, j).MergeArea(1, 1).Address Then
        xAux.EntireRow.Clear
        xAux.Value = .Cells(i, j).Text
        .Cells(i, j).Copy
        xAux.PasteSpecial Paste:=xlPasteFormats
        Largeur = 0
        For Each xcell In .Cells(i, j).MergeArea.Columns
          Largeur = Largeur + xcell.ColumnWidth
        Next xcell
        xAux.ColumnWidth = Largeur
        xAux.WrapText = True
        If .Cells(i, j).RowHeight < xAux.RowHeight Then .Cells(i, j).RowHeight = xAux.RowHeight
      End If
    End If
  Next j
Next i
xAux.Clear
End With
Application.ScreenUpdating = True
End Sub

 

[job75]

Re : Renvoie a la ligne automatiquement dans des cellules Fusionnées (vba)

Re, salut mapomme 🙂

La version (1) du post #4 ne traitait pas les lignes 5 et 9.

Cette version (2) traite toutes les cellules en rouge avec une macro paramétrée :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim t As Range
Set t = Intersect(Target, [F5:S5,AA5:AM5])
If Not t Is Nothing Then Ajustement t, [F:S], [AA:AM], xlCenter
Set t = Intersect(Target, [E9:AM9])
If Not t Is Nothing Then Ajustement t, [E:AM], [E:AM], xlCenter
Set t = Intersect(Target, [B14:Q40,AE14:AM40])
If Not t Is Nothing Then Ajustement t, [B:Q], [AE:AM], xlGeneral
End Sub

Sub Ajustement(t As Range, plage1 As Range, plage2 As Range, align)
Dim r1 As Range, r2 As Range, h As Double
Application.ScreenUpdating = False
For Each t In t ' si plusieurs cellules sont modifiées
  Set r1 = Intersect(t.EntireRow, plage1)
  Set r2 = Intersect(t.EntireRow, plage2)
  Union(r1, r2).UnMerge 'défusionne
  r1.HorizontalAlignment = xlCenterAcrossSelection
  r2.HorizontalAlignment = xlCenterAcrossSelection
  r1.WrapText = True: r2.WrapText = True 'renvoi à la ligne
  r1.Rows.AutoFit 'ajustement automatiquement
  h = r1.Rows.Height 'mémorise la hauteur
  r1.Merge: r2.Merge 'refusionne
  Union(r1, r2).HorizontalAlignment = align
  If h < 409 Then r1.RowHeight = h 'hauteur de ligne
Next
End Sub

Noter que pour les lignes 5 et 9 il a fallu défusionner les cellules qui ne sont pas en rouge...

A+

 

[Ilino]

Re : Renvoie a la ligne automatiquement dans des cellules Fusionnées (vba)

Bonsoir Forum
pblm résolu
merci : mapomme , job pour les réponse
grazie grazie