Macro "renvoi à la ligne automatiquement"

Bonsoir, rajoute et/ou remplace ces trois lignes :

For Each Cel In Range("A1:AB5")

On Error Resume Next ' <-----Ici

If Cel.MergeCells And Not Cel.Offset(0, -1).MergeCells Then ' <-----Ici

On Error GoTo 0 ' <-----Ici

Cel.Select

Euh j'ai du faire un caca car j'ai le message "Next sans For". Voici le code complet :

Sub AutoFitMergedCellRowHeight()

Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range, Cel As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
For Each Cel In ActiveSheet.UsedRange ' <--- Zone à déterminer
On Error Resume Next ' <-----Ici
If Cel.MergeCells And Not Cel.Offset(0, -1).MergeCells Then ' <-----Ici
On Error GoTo 0 ' <-----Ici
If Cel.MergeCells Then
Cel.Select
MergedCellRgWidth = 0: PossNewRowHeight = 0
With ActiveCell.MergeArea
.WrapText = True 'enclenche le renvoi à la ligne automatique (modif fs)
If .Rows.Count = 1 Then 'And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(Cel.Row, Cel.Column).ColumnWidth = MergedCellRgWidth
.VerticalAlignment = xlCenter
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(Cel.Row, Cel.Column).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
Next Cel
End Sub

Re-, Ps, en espérant qu'il n'y ait pas deux zones de cellules fusionnées côte à côte sur la même ligne.......

re-,

supprime la ligne :

On Error GoTo 0 ' <-----Ici

If Cel.MergeCells Then '<----Ici

Cel.Select

J'ai toujours un gros blanc avant et un gros blanc après ...

Là, je vois pas, chez moi, cela fonctionne.....

Peux-tu joindre un fichier exemple, exempt de toutes données confidentielles, avec le code fourni?

Edit : tu n'aurais pas, comme signalé plus haut, des lignes comportant plusieurs zones fusionnées?

Euh c'est un fichier pour le boulot sur lequel je bosse depuis 11 mois, que j'ai enfin terminé sauf cette macro pour perfectionner le tout ... donc je bosse sur un fichier excel bidon où je met quelques cellules fusionnées pour tenter vos codes.

Aurais-tu toi un fichier que je regarde ce qui cloche chez moi ?

Merci.

EDIT

Ah ben si, j'ai des lignes avec plusieurs zones de cellules fusionnées !!!

Ah ben si, j'ai des lignes avec plusieurs zones de cellules fusionnées !!!

Tu as la réponse....

si sur une même ligne, tu as plusieurs zones fusionnées, la hauteur de ligne va prendre la plus haute valeur....

Maintenant, si les deux zones sont contigües, pas facile.....

Bref, comme vu sur moult forums d'Excel, les cellules fusionnées et Excel, c'est pas vraiment ce qui se fait de mieux, c'est juste pour la présentation, pour le traimtement, c'est pas top.

Tu veux parler de :

- plusieurs fusions de cellules sur une même ligne ?

OU

- plus de 2 cellules sur une même fusion ?

Car j'ai le 2ème cas moi, à savoir juste plus de 2 cellules sur une même fusion sur une seule ligne ... et j'ai pourtant la grosse zone blanche (cf. fichier bidon joint : https://www.excel-pratique.com/~files/doc/RWtgAClasseur1.xls).

A te lire ...

Voici un code qui marche niquel :

Sub test4()
Dim FL1 As Worksheet, Cell As Range, LC1, LC2
Dim NbC As Byte, HC, HC1, Rat, Plage As Range
Dim ok As Boolean
Application.DisplayAlerts = False
    Set FL1 = Worksheets("Feuil1")
    FL1.Cells.WrapText = True
    Set Plage = FL1.Range("A1:" & FL1.Range("A1").SpecialCells(xlCellTypeLastCell).Address)
    For Each Cell In Plage
        'La est-elles fusionnée à une autre
        If FL1.Range(FL1.Cells(Cell.Row, Cell.Column), _
            FL1.Cells(Cell.Row, Cell.Column)).MergeCells Then
            NbC = 0
            LC1 = 0
            ok = Not Cell.Column = 1
            'Si /ok on ne fais pas le teste qui suit (Cell.column-1)
            If ok Then ok = ok And Not (FL1.Range(FL1.Cells(Cell.Row, Cell.Column - 1), _
            FL1.Cells(Cell.Row, Cell.Column - 1)).MergeCells)
            'mais si toujours ok, donc cellule de gauche non fusionnée, ou si la
            'cellule fusionnée testée se trouve sur la colonne 1
            'on traite
            'If Cell.Column = 1 Then Stop
            If ok Or Cell.Column = 1 Then
                HC1 = Cell.Height
                'On recherche la largeur totale de la cellule fusionnée
                'on peut adapter le nbre limite possible (ici 6) de cellules fusionnées
                For i = 0 To 10
                    If FL1.Range(FL1.Cells(Cell.Row, Cell.Column), _
                        FL1.Cells(Cell.Row, Cell.Column + i)).MergeCells Then
                        LC1 = LC1 + FL1.Cells(Cell.Row, Cell.Column + i).Width
                        'et on compte le nombre de cellules fusionnées
                        NbC = NbC + 1
                    End If
                Next
                'fractionnement de la cellule fusionnée
                FL1.Range(FL1.Cells(Cell.Row, Cell.Column), _
                    FL1.Cells(Cell.Row, Cell.Column)).UnMerge
                'On adapte la hauteur de ligne pour la cellule contenant le texte
                Rows(Cell.Row).AutoFit
                'mesure de la largeur de la cellule contenant le texte
                LC2 = FL1.Cells(Cell.Row, Cell.Column).Width
                'calcul du rapport entre la largeur des cellules fusionnées
                '... et la largeur de la cellule contenant le texte
                'Fusion des cellules
                FL1.Range(Cells(Cell.Row, Cell.Column), Cells(Cell.Row, Cell.Column + NbC - 1)).Merge
                DoEvents
                Rat = LC1 / LC2
                'Application du ratio pour Calcul de la hauteur de la cellule
                HC = Int((Cell.Height / Rat) + 0.5)
                'Application de la hauteur de ligne
                If HC > HC1 Then
                    FL1.Rows(Cell.Row & ":" & Cell.Row).RowHeight = HC
                    Else
                    FL1.Rows(Cell.Row & ":" & Cell.Row).RowHeight = HC1
                End If
            End If
        End If
    Next
End Sub

... mais, car il y a toujours un mais, on a une limite niveau caractères a priori donc si vous avez des infos là-dessus, je suis preneuse.

Merci.

re,

J'ai ajouté une macro supplémentaire qui va agir sur la plage utilisée et ce, de manière automatique.

En reprenant le code de départ.

Sub Trouvercellfusionnées()
Dim cell As Range
  With ActiveSheet.UsedRange
    For Each cell In .Cells
      With cell
          If .MergeCells = True Then
          .Activate
          .RowHeight = 12.75
          Call AutoFitMergedCellRowHeight
          End If
      End With
    Next cell
  End With
End Sub

Avec cette deuxième macro

Sub AutoFitMergedCellRowHeight()
'MAcro de Jim Rech
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
  If ActiveCell.MergeCells Then
    With ActiveCell.MergeArea
      .WrapText = True 'enclenche le renvoi à la ligne automatique (modif fs)
      If .Rows.Count = 1 Then 'And .WrapText = True Then
        Application.ScreenUpdating = False
        CurrentRowHeight = .RowHeight
        ActiveCellWidth = ActiveCell.ColumnWidth
        For Each CurrCell In Selection
          MergedCellRgWidth = CurrCell.ColumnWidth + _
            MergedCellRgWidth
        Next
       .MergeCells = False
       .Cells(1).ColumnWidth = MergedCellRgWidth
       .EntireRow.AutoFit
        PossNewRowHeight = .RowHeight
       .Cells(1).ColumnWidth = ActiveCellWidth
       .MergeCells = True
       .RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
         CurrentRowHeight, PossNewRowHeight)
      End If
    End With
  End If
End Sub

Toujours démarrer sur la macro Trouvercellfusionnées bien sûr.

Les deux macros sont à placer dans un module.

A te lire

Dan

Nad-Dan, ta macro "Trouvercellfusionnées" associée à la macro "AutoFitMergedCellRowHeight" marche niquel !!!

Je vais tester sur mon fichier réel pour voir le résultat et je vous tiens au courant ...

J'SUIS TROP CONTENTE ...

CA MARCHE IMPEC !!!

Je n'ai plus qu'à dire de le faire sur plusieurs feuilles nommées et le tour est joué !!! Un grand merci car je boucle 11 mois de travail sur ce fichier puisqu'il ne me manquait plus que cette macro que je n'ai pas réussi à faire seule ...

re,

Pour le faire sur plusieurs feuilles, pourquoi n'attribues-tu pas un raccourci clavier à cette macro ?

De cette sorte, tu sélectionnes la feuille concernée, puis par le raccourci ta macro sera exécutée.

A te lire

Dan

J'ai beaucoup de feuilles et je dois faire exécuter cette macro automatiquement ...

Donc elle fera partie des macros appelées lors de l'appui sur un bouton de validation présent dans ma feuille dite "formulaire".

Re,

Dans la macro Sub Trouvercellfusionnées, Il te suffit de rajouter :

en début de macro

Dim WS As Worksheet

Avant With ActiveSheet.UsedRange tu mets :

For Each WS In ActiveWorkbook.Sheets

Avant END SUB tu mets

Next WS

Amicalement

Dan

Merci Nad-Dan !!!

Alors apparemment cela ne prend pas toutes mes feuilles du classeurs (sachant qu'elles sont toutes nommées).

Par ailleurs, c'est en fait extrêment long donc peut-être faudrait-il trouver un truc qui dit de me chercher les cellules fusionnées où quelque chose est écrit ... ou alors nommer une plage sur toutes les feuilles (qui sont en fait les zones d'impression) pour ne faire la macro que sur ces zons définies ?

Bonsoir,

J'ai omis une petite instruction.

après For Each WS In ActiveWorkbook.Sheets ajoute ceci --> ws.Select

avant END SUB ajoute --> next WS

A te lire

Dan