Ajuster hauteur de cellules fusionnées

cathodique

cathodique

XLDnaute Barbatruc
Bonjour,

Afin d'éditer 3 feuilles dont les données sont extraites d'une BD. Un coup de main m'a été donné pour mettre un titre sur ces feuilles en utilisant "Select case".

Je voudrais compléter cette macro pour ajuster la hauteur de cellules fusionnées de la colonne "A". Car en l'état, le texte de certaines d'entre elles n'est visible pas dans sa totalité.

Cette colonne reçoit à partir de la BD, des valeurs de cellules concaténées avec des chr(10) entre chaque données (des renvois à la ligne). Je sais à priori que dans ces cellules fusionnées, il y aura toujours 3 lignes (ex: A&chr(10)&B&chr(10)&C ou A&chr(10)&" "&chr(10) ).
texte..............ou............texte.
texte............................
texte............................texte.

Par contre je ne connais pas le nombre de lignes fusionnées. Je sais simplement qu'elles ne seront jamais supérieures à 5.

Je n'arrive pas à ajuster ces cellules pour que tout le texte soit visible. Actuellement, le nombre de cellules fusionnées est 2, 3 et 4, mais il pourrait évoluer. Pire, je n'ai aucune idée. J'ai essayé de modifier la hauteur des cellules, faire un autofit des lignes mais le résultat est très décevant.

Je vous remercie par avance pour votre aide.

Cordialement,
 

Pièces jointes

  • Ajustement Hauteur texte cellules fusionnées.xls
    46.5 KB · Affichages: 62
Trier par date Trier par votes
J

Jack2

XLDnaute Occasionnel
Re : Ajuster hauteur de cellules fusionnées

Bonjour tout le monde,,

C'est encore moi cathodique. En attendant une meilleure solution tu peux essayer le code suivant :
Code: 
Sub Test()
Dim St As String
Dim T() As String

St = UCase("A&chr(10)&B&chr(10)&C")
T = Split(St, "CHR(10)")
NombreLigne = UBound(T) + 1 'nombre de CHR(10), retour à la ligne, + 1 (ligne d départ),
'soit le nombre total de lignes à fusionner
' ou 1 ligne de hauteur = 15 et une de hauteur = 30 si le résultat de la fusion ne correspond qu'à deux lignes
End Sub
J'espère que cela pourra t'aider
A+ Jack2
 
Vote positif 0 Vote négatif
cathodique

cathodique

XLDnaute Barbatruc
Re : Ajuster hauteur de cellules fusionnées

Bonjour Jack2,

Je suis content de te "revoir", si je puis m'exprimer ainsi. Je te remercie pour ton code.
Je constate encore une fois, qu'il n'est pas possible de solutionner un problème mal posé. En fait, dans mon poste #1, j'avais mis A&chr(10)&B&chr(10)&C&chr(10) ou A&chr(10)&""&chr(10)&C&chr(10), j'aurai dû mettre chaine de caractères au lieu des lettres A, B et C. Mes excuses, je t'ai peut-être induit en erreur.

Mais, même en remplaçant les chaines de caractères par les lettres A,B et C, je n'obtiens pas de résultat.

Entre temps j'ai trouvé le code ci-dessous, qui me donne en partie satisfaction en modifiant la valeur de la hauteur. La présentation au final n'est pas très bonne, surtout que sur mon fichier original dans l'entête des feuilles il y a des cellules fusionnées.
Code: 
Sub Trouvercellfusionnées()
Dim cell As Range
  With ActiveSheet.UsedRange
    For Each cell In .Cells
      With cell
          If .MergeCells = True Then
          .Activate
          .RowHeight = 30            'initialement il y avait 12.75
          Call AutoFitMergedCellRowHeight
          End If
      End With
    Next cell
  End With
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
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
Je trouve ton approche plus adaptée à mon cas, mais pour le moment elle ne fonctionne pas. je voudrais que le code n'agisse que sur la colonne A à partir de la 4ème ligne pour les 3 feuilles "A", "B" et "C".

En te remerciant beaucoup. Bonne journée.

Cordialement,
 
Vote positif 0 Vote négatif
J

Jack2

XLDnaute Occasionnel
Re : Ajuster hauteur de cellules fusionnées

Bonjour cathodique et le forum,

Si ta chaîne se présente ainsi, "AAAZ&chr(10)&CBBB&chr(10)&ADESC", cela ne change rien. Est-ce qu'à une ligne fusionnée en colonne A peut correspondre sur les autres colonnes des lignes de tailles différentes ?

Si ce n'est pas clair, je t'enverrai un fichier ce soir

A+ Jack2
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Ajuster hauteur de cellules fusionnées

Bonjour cathodique, Jack2,

Si j'ai bien compris le problème :

Code: 
Sub HauteurCelluleFusionnée()
Dim c As Range, ma As Range
Application.ScreenUpdating = False
For Each c In Range("A6", [A65536].End(xlUp))
  Set ma = c.MergeArea
  If ma.Count > 1 And c <> "" Then
    ma.UnMerge
    c.Rows.AutoFit 'ajustement automatique
    ma.Rows.RowHeight = c.RowHeight / ma.Count 'hauteurs égales
    ma.Merge
  End If
Next
End Sub
A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Ajuster hauteur de cellules fusionnées

Re,

Si l'on estime les marges insuffisantes on peut par exemple ajouter +5 :

Code: 
Sub HauteurCelluleFusionnée()
Dim c As Range, ma As Range
Application.ScreenUpdating = False
For Each c In Range("A6", [A65536].End(xlUp))
  Set ma = c.MergeArea
  If ma.Count > 1 And c <> "" Then
    ma.UnMerge
    c.Rows.AutoFit 'ajustement automatique
    ma.Rows.RowHeight = (c.RowHeight + 5) / ma.Count 'hauteurs égales
    ma.Merge
  End If
Next
End Sub
A+
 
Vote positif 0 Vote négatif
cathodique

cathodique

XLDnaute Barbatruc
Re : Ajuster hauteur de cellules fusionnées

Bonjour Job75,

Tu as très bien compris mon problème. C'est extra, ça fonctionne comme je le souhaitais. J'ai testé ton code (pas à pas) sur les 3 feuilles, le résultat est bon. Mais...
Sans trop vouloir abuser de ta gentillesse, pour intégrer ton code à ma macro, j'ai un souci. J'ai fait un "Call" à ton code et là, ça ne fonctionne plus.
Ne t'étonnes pas, je suis en phase d'apprentissage. Je te sollicite pour un second coup de main.
Où dois-je mettre le call? Ou bien y a-t-il quelque chose à ajouter au code?
Code: 
Sub Titre_CMDP()
Dim derlig As Long, DerCol As Long
Dim Tp
Dim Ind As Byte
Application.ScreenUpdating = False
 
Tp = Array("A", "B", "C")
 
For Ind = 0 To 2
    With Worksheets(Tp(Ind))
    DerCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
    derlig = .Cells(Application.Rows.Count, 1).End(xlUp).Row

Select Case Ind
        Case 0 'pour feuilleA
            .Range("A1") = "Région"
            .Range("B1") = "RAPPORT CONCERNANT A"
            .Cells(1, DerCol + 6) = Sheets("données").Range("A1")
            .Cells(1, DerCol + 5) = "Date:"

        Case 1, 2   'pour feuilles B et C
            .Range("A1") = "Région"
            .Range("B1") = "RAPPORT CONCERNANT BC"
            .Cells(1, DerCol) = Sheets("données").Range("A1")
            .Cells(1, DerCol - 1) = "Date:"
      End Select
          Call HauteurCelluleFusionnée      'j'appelle ici ta macro et je n'ai pas de résultat
    End With
Next Ind
    MsgBox "Terminé!"
End Sub
Je te remercie beaucoup. Y a pas à dire tu t'y connais en VBA. 1000 Mercis.

Cordialement,
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Ajuster hauteur de cellules fusionnées

Re,

Ma macro, mise dans un module standard, s'appliquait à la feuille active.

Pour l'appliquer à une feuille quelconque il faut la paramétrer :

Code: 
Sub HauteurCelluleFusionnée(plage As Range)
Dim c As Range, ma As Range
Application.ScreenUpdating = False
For Each c In plage
  Set ma = c.MergeArea
  If ma.Count > 1 And c <> "" Then
    ma.UnMerge
    c.Rows.AutoFit 'ajustement automatique
    ma.Rows.RowHeight = (c.RowHeight + 5) / ma.Count 'hauteurs égales
    ma.Merge
  End If
Next
End Sub
Et dans votre macro, pour l'appliquer aux 3 feuilles, vous l'appelez par l'instruction :

Code: 
If derlig > 5 Then Call HauteurCelluleFusionnée(.Range("A6:A" & derlig))
ou plus simplement par :

Code: 
If derlig > 5 Then HauteurCelluleFusionnée .Range("A6:A" & derlig)
A+
 
Vote positif 0 Vote négatif
cathodique

cathodique

XLDnaute Barbatruc
Re : Ajuster hauteur de cellules fusionnées

Messieurs Bonsoir,

Je vous remercie beaucoup l’Intérêt que vous avez porté à ma présente discussion et surtout pour votre précieuse aide. Sinon, ma macro n'aurait jamais avancé.

En exécutant le code pas à pas, je me suis rendu compte que la macro fonctionne pour la feuille active.

j'ai repris le dernier code, mais ça ne fonctionne pas. Comme vous me l'avez souligné, il faut paramétrer la macro pour qu'elle s’exécute pour les 3 feuilles. là aussi, je bloque. Oui je sais, je suis nul. Voici ma macro et la dernière macro de Job75.
Code: 
Sub Titre_CMDP()
Dim derlig As Long, DerCol As Long
Dim Tp
Dim Ind As Byte
Application.ScreenUpdating = False
 
Tp = Array("A", "B", "C")
 
For Ind = 0 To 2
    With Worksheets(Tp(Ind))
    DerCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
    derlig = .Cells(Application.Rows.Count, 1).End(xlUp).Row

Select Case Ind
        Case 0 'pour feuilleA
            .Range("A1") = "Région"
            .Range("B1") = "RAPPORT CONCERNANT A"
            .Cells(1, DerCol + 6) = Sheets("données").Range("A1")
            .Cells(1, DerCol + 5) = "Date:"

        Case 1, 2   'pour feuilles B et C
            .Range("A1") = "Région"
            .Range("B1") = "RAPPORT CONCERNANT BC"
            .Cells(1, DerCol) = Sheets("données").Range("A1")
            .Cells(1, DerCol - 1) = "Date:"
        
        If derlig > 5 Then HauteurCelluleFusionnée .Range("A6:A" & derlig)
    
    End Select
    
   ' If derlig > 5 Then HauteurCelluleFusionnée .Range("A6:A" & derlig)
    
    End With
Next Ind
    MsgBox "Terminé!"

End Sub

Sub HauteurCelluleFusionnée(plage As Range)
Dim c As Range, ma As Range
Application.ScreenUpdating = False
For Each c In plage
  Set ma = c.MergeArea
  If ma.Count > 1 And c <> "" Then
    ma.UnMerge
    c.Rows.AutoFit 'ajustement automatique
    ma.Rows.RowHeight = (c.RowHeight + 5) / ma.Count 'hauteurs égales
    ma.Merge
  End If
Next
End Sub
Je vous remercie beaucoup.
Bonne soirée.

Cordialement,
 
Vote positif 0 Vote négatif
cathodique

cathodique

XLDnaute Barbatruc
Re : Ajuster hauteur de cellules fusionnées

Re, Job75

En effet, la ligne mise en commentaire ne s’exécute. j'ai effectué un test avec cette ligne après la fermeture "end select et avant le "end with. Comme ça n'a rien donné, je l'ai mise avant la fin du "end select et l'ai mise en commentaire (pour voir si elle s’exécutait pour les feuilles B et C).
j'ai paramétré la plage. J'ai modifié manuellement les hauteurs pour effectuer un test, mais il n'est pas concluant.
voici le code complet:
Code: 
Sub Titre_CMDP()
Dim derlig As Long, DerCol As Long
Dim plage As Range
Dim Tp
Dim Ind As Byte
Application.ScreenUpdating = False
 
Tp = Array("A", "B", "C")
 
For Ind = 0 To 2
    With Worksheets(Tp(Ind))
    Sheets(Tp(Ind)).Activate
    DerCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
    derlig = .Cells(Application.Rows.Count, 1).End(xlUp).Row
    ''''''''''''''''''''''''''''''''''''
    Set plage = .Range("A6:A" & derlig)

Select Case Ind
        Case 0 'pour feuilleA
            .Range("A1") = "Région"
            .Range("B1") = "RAPPORT CONCERNANT A"
            .Cells(1, DerCol + 6) = Sheets("données").Range("A1")
            .Cells(1, DerCol + 5) = "Date:"

        Case 1, 2   'pour feuilles B et C
            .Range("A1") = "Région"
            .Range("B1") = "RAPPORT CONCERNANT BC"
            .Cells(1, DerCol) = Sheets("données").Range("A1")
            .Cells(1, DerCol - 1) = "Date:"
End Select
    
    If derlig > 5 Then HauteurCelluleFusionnée .Range("A6:A" & derlig)
    
    End With
Next Ind
    MsgBox "Terminé!"

End Sub

Sub HauteurCelluleFusionnée(plage As Range)
Dim c As Range, ma As Range
Application.ScreenUpdating = False
For Each c In plage
  Set ma = c.MergeArea
  If ma.Count > 1 And c <> "" Then
    ma.UnMerge
    c.Rows.AutoFit 'ajustement automatique
    ma.Rows.RowHeight = (c.RowHeight + 5) / ma.Count 'hauteurs égales
    ma.Merge
  End If
Next
End Sub
Voilà, je n'arrive pas à trouver à quel niveau sont mes erreurs. Je joins mon fichier.

Merci. Bonne soirée.

Cordialement,
 

Pièces jointes

  • Ajustement Hauteur 2.xls
    50.5 KB · Affichages: 58
Vote positif 0 Vote négatif
cathodique

cathodique

XLDnaute Barbatruc
Re : Ajuster hauteur de cellules fusionnées

Re, autant pour moi, je viens de me rendre compte qu'avec ce dernier code ça fonctionne bien.

Pour faire un autre test, j'ai modifié manuellement la hauteur des lignes. Donc ce sont les cellules non fusionnées qui ne sont par traitées. Comment introduire cette éventualité dans le code.

Merci pour tout. Bonne soirée.

Cordialement,
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Ajuster hauteur de cellules fusionnées

Re,

Ah cathodique ! Le titre de ce fil est "Ajuster hauteur de cellules fusionnées".

Ma macro ne traitait donc que ces cellules, vous deviez savoir comment faire pour les cellules non fusionnées.

Maintenant s'il faut aussi ajuster les cellules non fusionnées il suffit d'ajouter plage.Rows.AutoFit :

Code: 
Sub HauteurCelluleFusionnée(plage As Range)
Dim c As Range, ma As Range
Application.ScreenUpdating = False
plage.Rows.AutoFit 'ajustement des cellules non fusionnées
For Each c In plage
  Set ma = c.MergeArea
  If ma.Count > 1 And c <> "" Then
    ma.UnMerge
    c.Rows.AutoFit 'ajustement automatique
    ma.Rows.RowHeight = (c.RowHeight + 5) / ma.Count 'hauteurs égales
    ma.Merge
  End If
Next
End Sub
A+
 
Vote positif 0 Vote négatif
cathodique

cathodique

XLDnaute Barbatruc
[RESOLU] : Ajuster hauteur de cellules fusionnées

Bonjour Job75,

Excusez mon incompétence en VBA et rédaction. En effet, le titre était "Ajuster hauteur de cellules fusionnées". Peut-on Récapituler un problème en une seule phrase et de surplus dont le nombre de caractères est limité? Je reconnais que j'ai mal exposé mon problème.

Je vous remercie tous autant que vous êtes. En commençant par ceux qui m'ont aidé, ils ont plus de mérite.Ainsi que ceux et celles qui ont consulté ma discussion.

Maintenant ce problème est résolu. Merci encore, je vais pouvoir avancer.

Très bonne journée à tous.

Cordialement,
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

KTM
  • Question
XL 2016 Ajuster les lignes au Contenu
Réponses
4
Affichages
177
KTM
KTM
philsogood
  • Question
XL 2016 convertir cellules fusionnées
Réponses
11
Affichages
401
philsogood
philsogood
chaelie2015
  • Résolu(e)
XL 2013 (RESOLU) Gestion automatique des indications de saisie dans les cellules
Réponses
2
Affichages
227
chaelie2015
chaelie2015
E
  • Résolu(e)
Microsoft 365 Grand Livre données exploitables
2
Réponses
28
Affichages
620
eric72
E
E
  • Résolu(e)
Microsoft 365 Boucle sur lignes <>0
Réponses
2
Affichages
166
eric72
E
S
  • Résolu(e)
Microsoft 365 RechercheV et cellules fusionnées = 0
Réponses
6
Affichages
319
Spidtrip
S
F
  • Résolu(e)
Microsoft 365 Supprimer des lignes en fonction de la date et de l'heure
Réponses
8
Affichages
313
AtTheOne
AtTheOne
Z
  • Résolu(e)
Microsoft 365 Problème de combinaison entre fonctions "If Then Else" et "SelectCase"
Réponses
11
Affichages
275
Zonmé
Z
T
  • Résolu(e)
XL 2019 Calculer le nombre de lignes pour impression (pdf ou physique)
Réponses
1
Affichages
109
ThierryP
T
C
  • Résolu(e)
XL 2019 Moyenne avec de nouvelles valeurs
Réponses
5
Affichages
188
cotignac
C

Membres actuellement en ligne

7 membres et 78 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 370
Messages
2 087 693
Membres
103 641
dernier inscrit
anouarkecita2