XL 2016 Autofit de plusieurs cellules fusionnées via vba

[dindin]

Bonjour,
je dois préparer un document qui se rempli depuis une base de donnée via la formule RechercheV, et ensuite on génère un PDF.
la base se rempli depuis un formulaire.
Tout le travail est presque finalisé.
je bloque, sur une macro qui me permettra de faire un Autofit de plusieurs cellule fusionnées selon le contenu ( nombre de ligne ) et de mettre uniquement le mot Article+N en gras à chaque changement.
je vous joins un exemple.
j'aurai besoin de votre aide
Merci

 

[TooFatBoy]

Bonjour,

je bloque, sur une macro qui me permettra de faire un Autofit de plusieurs cellule fusionnées selon le contenu ( nombre de ligne ) et de mettre uniquement le mot Article+N en gras à chaque changement.
je vous joins un exemple.

Tu t'es trompé de fichier : il n'y a pas de macro dans celui que tu as posté...


Un autofit sur une plage de cellules fusionnées ???
Du coup, comment on fait :
- on élargi une seule des colonnes de la plage ?
- on élargi chacune des colonnes du même pourcentage ?
- autre ?

 

[dindin]

Bonjour,


Tu t'es trompé de fichier : il n'y a pas de macro dans celui que tu as posté...


Un autofit sur une plage de cellules fusionnées ???
Du coup, comment on fait :
- on élargi une seule des colonnes de la plage ?
- on élargi chacune des colonnes du même pourcentage ?
- autre ?

voici un fichier avec le code que j'ai réussi à l'adapter sauf pour les cellules fusionnées qui contiennent une formule. Merci pour ton aide.

 

[dindin]

Est ce que quelqu'un peut m'aider ?

 

[wDog66]

Bonjour dindin

QQ c'est quoi ?

Est-ce que vous êtes bègue (humour)

 

[job75]

Bonjour à tous,

Le code de Feuil3 :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cell As Range
    For Each cell In Range("A1:A18")
        If cell Like "Article #*" Then
            With cell.MergeArea
                .UnMerge 'défusionne
                .Font.Bold = True
                .EntireColumn.AutoFit
                .Merge 'refusionne
            End With
        End If
    Next cell
End Sub

A+

 

[dindin]

Bonjour à tous,

Le code de Feuil3 :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cell As Range
    For Each cell In Range("A1:A18")
        If cell Like "Article #*" Then
            With cell.MergeArea
                .UnMerge 'défusionne
                .Font.Bold = True
                .EntireColumn.AutoFit
                .Merge 'refusionne
            End With
        End If
    Next cell
End Sub

A+

Bonjour job75,
le code ne fonctionne pas .
Par contre ce code fonctionne pour la hauteur automatique des cellules fusionnées contenant une formule, mais il met tout le contenu en gras

Option Explicit

Sub HauteurLigneMergeArea(MergedZone As Range)
  Dim Zone1Cel As Range
  Dim Ind As Long
  Dim LargeurTotale As Single
  ' Désactiver les événements
  Application.EnableEvents = False
  ' Définir la cellule qui va contenir le texte
  Set Zone1Cel = ActiveSheet.Range("Z" & MergedZone.Row)
  'Déterminer la largeur totale de la zone fusionnée
  For Ind = 1 To MergedZone.Columns.Count
    LargeurTotale = LargeurTotale + MergedZone.Columns(Ind).ColumnWidth
  Next
  ' Appliquer la largeur totale à la colonne 1
  Zone1Cel.ColumnWidth = LargeurTotale - 1
  ' Inscrire dedans le texte
  Zone1Cel.Value = MergedZone.Cells(1, 1).Value
  ' Appliquer le retour à la ligne de la cellule unique
  ' et son ajustement automatique
  With Zone1Cel
    .WrapText = False
    .WrapText = True
    .Rows.AutoFit
  End With
  ' Forcer la hauteur de ligne
  MergedZone.RowHeight = Zone1Cel.RowHeight
  ' Effacer le contenu de la cellule unique
  Zone1Cel.Clear
  ' Réactiver les événements
  Application.EnableEvents = True
End Sub

Sub MettreEnForme()
    Dim cell As Range
    Dim searchText As String
    Dim startPos As Integer
    Dim numberPart As String
    Dim Target As Range
    
    ' Définir le texte à rechercher
    searchText = "Article "
    
    ' Parcourir chaque cellule dans la plage A1:A18
    For Each cell In Range("A1:A18")
        ' Vérifier si la cellule commence par le texte recherché
        If Left(cell.Value, Len(searchText)) = searchText Then
            ' Trouver la position du premier espace après "Article +"
            startPos = Len(searchText) + 1
            Do While Mid(cell.Value, startPos, 1) <> " " And startPos <= Len(cell.Value)
                startPos = startPos + 1
            Loop
            
            ' Extraire le numéro après "Article +"
            numberPart = Mid(cell.Value, Len(searchText) + 1, startPos - Len(searchText) - 1)
            
            ' Mettre "Article +N" en gras
            cell.Characters(Start:=1, Length:=Len(searchText) + Len(numberPart)).Font.Bold = True
            
            ' Si la cellule a du texte après "Article +N", le laisser en normal (non gras)
            If Len(cell.Value) > Len(searchText) + Len(numberPart) Then
                cell.Characters(Start:=Len(searchText) + Len(numberPart) + 1).Font.Bold = False
            End If
            
            ' Ajuster la largeur de la cellule
            cell.Rows.AutoFit
        End If
    Next cell
    
    ' Ajuster la hauteur des lignes des cellules fusionnées dans la plage A1:A15
    On Error Resume Next
    For Each cell In ActiveSheet.Range("A1:A15")
        Set Target = cell
        If Not Target Is Nothing Then Call HauteurLigneMergeArea(Target.MergeArea)
    Next cell
    On Error GoTo 0
End Sub

y'a t'il une solution à ce bug. je joins le fichier.
Merci

 

[job75]

Bonjour dindin,

Mon code fonctionne bien et il n'y a aucun bug.

Vous devriez savoir que quand une cellule contient une formule tous les caractères sont forcément au même format.

A+