Largeur et hauteur automatisées des cellules en fonction du contenu

Bonjour,

Les largeurs et hauteurs de lignes ne tiennent pas avec l'option "Format" des cellules. J'ai testé plusieurs fois sur cette feuille "Médailles Hommes" mais ça ne marche pas

Je pense qu'il faudra que je passe par du VBA à moins qu'il y aurait une autre solution.

Vous savez faire ?

Voici le code VBA ==>

Sub PDF_Medailles_Hommes()
     Dim FileN$, Maintenant, AppShell

     Maintenant = Format(Now, "yyyymmdd_hhmmss")
     s = Dossier                             'fonction pour déterminer le nom du dossier pour sauvegarder le pdf
     If vbNo = MsgBox("le pdf sera sauvegardé dans le dossier : " & vbLf & s & vbLf & vbLf & "si vous voulez un autre dossier choississez ""Non""", vbYesNo, "Nom du dossier") Then
          s = ChoisirDossier
     End If

     If s = "" Then MsgBox "dossier inconnu": Exit Sub
     FileN = s & "\@_" & Maintenant & ".pdf"     'chemin pour BsAlv

     With Range("Medailles_H")

          Set c = .Offset(-1).Resize(.Rows.Count + 1)     'plage à exporter vers le pdf
          .Parent.Shapes("ZoneTexte 2").OLEFormat.Object.PrintObject = msoTrue     'imprimer cette forme !!!
          Application.PrintCommunication = False
          With .Parent.PageSetup
               .PrintArea = c.Address
               .LeftMargin = Application.CentimetersToPoints(0.5)
               .RightMargin = Application.CentimetersToPoints(0.5)
               .TopMargin = Application.CentimetersToPoints(0)
               .BottomMargin = Application.CentimetersToPoints(0)
               .HeaderMargin = Application.InchesToPoints(0)
               .FooterMargin = Application.InchesToPoints(0)
               '.Orientation = xlPortrait on ne choisit plus l'orientation
               .CenterHorizontally = True

               '.Zoom = False

               .FitToPagesTall = 0
               .FitToPagesWide = 1

          End With
          FileN = Replace(Replace(FileN, "@", "Challenge_Médailles_Femmes"), "Maintenant", Format(Now, "yymmdd_hhmmss"))
          c.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FileN, OpenAfterPublish:=True
     End With
     Shell_LaunchWindowsExplorer Left(FileN, InStrRev(FileN, "\") - 1)
End Sub

Ce n'est pas sûr que vous en ayez besoin mais je mets quand même les mdp :

Sur le bouton "Débloquer ou Quitter", tapez vodoraix pour tt débloquer.

Et mot de passe pour débloquer les feuilles ==> seb

Merci beaucoup...

Bon dimanche

Code à tester

Sub PDF_Medailles_Hommes()
    Dim FileN$, Maintenant, AppShell

    Maintenant = Format(Now, "yyyymmdd_hhmmss")
    s = Dossier                             'fonction pour déterminer le nom du dossier pour sauvegarder le pdf
    If vbNo = MsgBox("le pdf sera sauvegardé dans le dossier : " & vbLf & s & vbLf & vbLf & "si vous voulez un autre dossier choississez ""Non""", vbYesNo, "Nom du dossier") Then
        s = ChoisirDossier
    End If

    If s = "" Then MsgBox "dossier inconnu": Exit Sub
    FileN = s & "\@_" & Maintenant & ".pdf"     'chemin pour BsAlv

    With Range("Medailles_H")
        Set c = .Offset(-1).Resize(.Rows.Count + 1)     'plage à exporter vers le pdf

        ' Ajustement de la largeur des colonnes
        .Columns.AutoFit  ' Ajuste automatiquement la largeur de toutes les colonnes
        ' Vous pouvez spécifier une largeur particulière pour chaque colonne si nécessaire
        '.Columns(1).ColumnWidth = 15  ' Exemple : définir la largeur de la première colonne à 15

        ' Ajustement de la hauteur des lignes
        .Rows.AutoFit  ' Ajuste automatiquement la hauteur de toutes les lignes
        ' Vous pouvez spécifier une hauteur particulière pour chaque ligne si nécessaire
        '.Rows(1).RowHeight = 20  ' Exemple : définir la hauteur de la première ligne à 20

        .Parent.Shapes("ZoneTexte 2").OLEFormat.Object.PrintObject = msoTrue     'imprimer cette forme !!!
        Application.PrintCommunication = False
        With .Parent.PageSetup
            .PrintArea = c.Address
            .LeftMargin = Application.CentimetersToPoints(0.5)
            .RightMargin = Application.CentimetersToPoints(0.5)
            .TopMargin = Application.CentimetersToPoints(0)
            .BottomMargin = Application.CentimetersToPoints(0)
            .HeaderMargin = Application.InchesToPoints(0)
            .FooterMargin = Application.InchesToPoints(0)
            '.Orientation = xlPortrait on ne choisit plus l'orientation
            .CenterHorizontally = True

            '.Zoom = False

            .FitToPagesTall = 0
            .FitToPagesWide = 1

        End With
        FileN = Replace(Replace(FileN, "@", "Challenge_Médailles_Femmes"), "Maintenant", Format(Now, "yymmdd_hhmmss"))
        c.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FileN, OpenAfterPublish:=True
    End With
    Shell_LaunchWindowsExplorer Left(FileN, InStrRev(FileN, "\") - 1)
End Sub

Merci beaucoup Joco7915

Ca ne fonctionne pas, dommage :

Mais en réalité, il faudrait agir à la source et non sur le pdf, désolé, c'est davantage logique, j'y ai pensé qu'après

Voici le code qui serait à améliorer ==>

Private Sub Worksheet_Activate()
     With Me
          .Protect MdP, UserInterfaceOnly:=True ' juste pour l'essai, on met la protection
          .Range("C1:F1").EntireColumn.AutoFit
     End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
     With Me
          .Protect MdP, UserInterfaceOnly:=True ' juste pour l'essai, on met la protection
          .Range("C1:F1").EntireColumn.AutoFit
     End With
End Sub

D'ailleurs sur un autre classeur, BsAlv m'avait trouvé un code qui fonctionnait. Il faudrait juste l'adapter à ce fichier. Avec évidemment des Range que j'adapterai.

Puisque que ça n'est pas B1:J1 pour les colonnes, mais C1:F1 dans ce nouveau classeur

Et les lignes, ça va de A3:A12 + A14.

Private Sub Worksheet_Activate()
     Medailles
     With Me.Range("A1")
          .Value = .Value                    'lancer "change"
     End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
     With Me
          .Range("B1:J1").ColumnWidth = 50   'largeur exagéré
          .Range("B:J").EntireColumn.AutoFit
          For i = 2 To 10
               Columns(i).ColumnWidth = Application.Max(1, Columns(i).ColumnWidth - 1)     'éviter d'avoir une valeur négative
          Next i
          .Range("I1").ColumnWidth = 2       'colonne noire
     End With
End Sub

Merci beaucoup

Bonne soirée