En VBA, sélectionner des colonnes en masquant les autres pour créer 1 pdf

Bonjour,

On m'a créé sur un autre classeur, une box qui fonctionne d'ailleurs à merveille, avec cases à cocher afin de sauvegarder une sélection en pdf.

Mais en créant un autre classeur avec ce même système de box et malgré des aides précieuses, on n'a pas réussi à adapter correctement le code.

Il s'agit d'épreuves sportives qui sont différentes du classeur précédent avec un nombre différent de colonnes associées, d'où certainement des erreurs de résultats.

En cliquant sur ce bouton, on arrive à une boîte avec cases à cocher ==>

L'ancienne box sur l'ancien classeur :

La nouvelle :

Mais sur ce nouveau classeur, les épreuves restent masquées, seules les colonnes de bases apparaissent :

Voici le code VBA provenant du module de l'objet "Saisie" :

Private Sub Masquer()
    Dim k, r1, r2, b, r, r3, cle
    With Range("tabel1").ListObject         'votre tableau
        '.Range.AutoFilter                  'enlever les filtres
        .Range.EntireColumn.Hidden = False     'montrer toutes les colonnes du tableau
        '   .Range.Columns(1).BorderAround LineStyle:=xlContinuous, Weight:=xlThick, ColorIndex:=3

        MFC                                'mettre à jour toutes lesMFCs
        .Range.EntireColumn.Hidden = True  'cacher toutes les colonnes du tableau
        I = .ListColumns("E_1").Index      'numéro de la Listcolumn "E_1", donc première épreuve
        .Range.Resize(, I - 1).EntireColumn.Hidden = False     'montrer les listcolumns à partir de la 2eme jusqu'à la colonne avant "épreuve 1"
        .Range.Cells(1, .Range.Columns.Count).ColumnWidth = 0.1
        Cnt = 0
        For k = 8 To 1 Step -1            'boucler les checkboxes de 8 à 1
            If Me.Controls("CheckBox" & k).Value = True Then     'il est coché ?
                Cnt = Cnt + 1            'compteur+1
                If k <= 7 Then          'checkbox d'une épreuve
                    r1 = Application.IfError(Application.Match("E_" & k, .HeaderRowRange, 0), 0)
                    If r1 = 0 Then
                        MsgBox "problème avec épreuve " & k
                    Else
                        Exit Sub     'listcolumn début de cette épreuve
                    End If

                    '***********************************************************************************
                    If k <= 3 Or k = 5 Then
                        r2 = Application.IfError(Application.Match("Essai_" & k, .HeaderRowRange, 0), 0)
                        If r2 = 0 Then
                            MsgBox "problème avec Essai " & k
                        Else
                            Exit Sub     'listcolumn fin de cette épreuve
                        End If
                    ElseIf k = 4 Or k >= 6 Then
                        r2 = Application.IfError(Application.Match("Pts_" & k, .HeaderRowRange, 0), 0)
                        If r2 = 0 Then
                            MsgBox "problème avec Pts " & k
                        Else
                            Exit Sub     'listcolumn fin de cette épreuve
                        End If
                    End If
                    '***********************************************************************************

                    r3 = Application.IfError(Application.Match("CLT" & k, .HeaderRowRange, 0), 0)
                    If r3 = 0 Then
                        MsgBox "problème avec CLT" & k
                    Else
                        Exit Sub     'listcolumn du classement de cette épreuve                    Else                     'pour classement général
                    End If
                    r2 = .ListColumns.Count - 1     'listcolumn fin = avant-dernière listcolumn du tableau
                    r1 = r2 - 3         'listcolumn du début = 2 vers gauche
                    r3 = r2 - 1         'listcolumn classement est égal à r2-1
                End If

                .HeaderRowRange.Cells(1, r1).Resize(, r2 - r1 + 1).EntireColumn.Hidden = False     'montrer cette épreuve
                If k = 8 Then
                    Nom_Epreuve = "Classement"
                Else
                    Nom_Epreuve = .HeaderRowRange.Cells(0, r1).Value2     'nom de l'épreuve à utiliser dans le nom du PDF
                End If
                '  sp = Split(.HeaderRowRange.Cells(2, r1).FormulaR1C1, ",") 'formule utilisée pour créer le rang
                '    Cle =iif(sp(ubound(sp)) like "1)*",  xlDescending
                '       Case Else: Cle = xlAscending     'les autres ascending
                '  End Select

                If r3 > 0 Then           'listcolumn "classement" est connue
                    With .Range
                        .Sort .Cells(1, r3), xlAscending, Header:=xlYes     'trier colonne classement "ascendant" ou "descendant"
                    End With
                End If
                .Range.AutoFilter r1, "<>"     'cacher toutes les lignes avec une cellule vide dans la première colonne de cette épreuve
            End If
        Next
    End With
End Sub

En tout cas des erreurs peuvent provenir de r1 :

r2 = .ListColumns.Count - 1 'listcolumn fin = avant-dernière listcolumn du tableau
r1 = r2 - 3 'listcolumn du début = 2 vers gauche
r3 = r2 - 1 'listcolumn classement est égal à r2-1

r1 n'est pas toujours égale à r2 - 3 ==> pas pour épreuves 1, 2, 3 & 5 (c'est r2 - 4). Mais ça n'explique pas pourquoi toutes les colonnes d'une épreuve sont masquées

Une piste ?

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

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

Comme je l'avais écrit dans mes sujets précédents tous les noms de familles sont une pure invention, sortis de ma mémoire, au hasard, après 26 années professionnelles. Et sans lien avec les prénoms ni aucune date de naissance, je vous rassure

En tout cas merci beaucoup de me lire

Bon dimanche

Bonjour,

Ci-joint le contenu du module de la feuille "Saisie"

Dim N°ColDeb As Long, N°ColFin As Long
Dim ColDeb As String, ColFin As String

Private Sub UserForm_Initialize()
     CheckboxUnique 11                       'au lancement de l'UF,on coche "classement général"
End Sub

Private Sub CheckboxUnique(N°)               'N° est le numéro du checkbox qu'on veut cocher !
     'macro commune pour les 11 macros suivantes pour éviter plusieurs "checkboxes cochés"
     For I = 1 To 8                        'boucler les 8 checkboxes
          With Me.Controls("CheckBox" & I)   'ce checkbox
               b = (I = N°)                  'drapeau c'est le checkbox voulu
               If b <> .Value Then .Value = b: DoEvents     'si statut du checkbox n'est pas le statut voulu, change-le
          End With
     Next
End Sub

Private Sub CheckBox1_afterupdate()          'macro lancée automatiquement quand on coche checkbox1
     CheckboxUnique 1                        'alors on lance cette macro commune pour éviter un autre checkbox coché
     N°ColDeb = 8
     N°ColFin = 12
End Sub
Private Sub CheckBox2_afterupdate()
     CheckboxUnique 2
     N°ColDeb = 13
     N°ColFin = 17
End Sub
Private Sub CheckBox3_afterupdate()
     CheckboxUnique 3
     N°ColDeb = 18
     N°ColFin = 22
End Sub
Private Sub CheckBox4_afterupdate()
     CheckboxUnique 4
     N°ColDeb = 23
     N°ColFin = 26
End Sub
Private Sub CheckBox5_afterupdate()
     CheckboxUnique 5
     N°ColDeb = 27
     N°ColFin = 31
End Sub
Private Sub CheckBox6_afterupdate()
     CheckboxUnique 6
     N°ColDeb = 32
     N°ColFin = 35
End Sub
Private Sub CheckBox7_afterupdate()
     CheckboxUnique 7
     N°ColDeb = 36
     N°ColFin = 39
End Sub
Private Sub CheckBox8_afterupdate()
     CheckboxUnique 8
     N°ColDeb = 40
     N°ColFin = 43
End Sub

Private Sub Ok_Click()
     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

     Range("tabel1").Parent.Unprotect MdP
     'Me.Hide
     Masquer
     Unload Me

     With Range("tabel1").ListObject.Range
          '  .Columns(1).BorderAround LineStyle:=xlContinuous, Weight:=xlThick
          If Cnt <> 1 Then MsgBox "seulement 1 coche", vbExclamation: GoTo 1
          Application.PrintCommunication = False
          With .Parent.PageSetup
               .LeftMargin = Application.CentimetersToPoints(1)
               .RightMargin = Application.CentimetersToPoints(1)
               .TopMargin = Application.CentimetersToPoints(1)
               .BottomMargin = Application.CentimetersToPoints(1)
               .HeaderMargin = Application.InchesToPoints(0)
               .FooterMargin = Application.InchesToPoints(0)
               .Zoom = False
               .FitToPagesWide = 1
               .FitToPagesTall = 6
          End With
          Application.PrintCommunication = True
          Range("pdf").Value = 1
          .Rows(1).EntireRow.Hidden = True   'cacher headerrowrange
          '.Columns(1).EntireColumn.Hidden = True     'cacher headerrowrange
Debug.Print .Offset(-1).Resize(.Rows.Count + 1).Address
          With .Offset(-1).Resize(.Rows.Count + 2)
               'MsgBox .Address
               '.PrintPreview
               FileN = Replace(Replace(FileN, "@", Nom_Epreuve), vbLf, "_")
               .ExportAsFixedFormat Type:=xlTypePDF, Filename:=FileN, OpenAfterPublish:=True
          End With

          Shell_LaunchWindowsExplorer Left(FileN, InStrRev(FileN, "\") - 1)

1:
          .Rows(1).EntireRow.Hidden = False  'montrer headerrowrange
          Range("pdf").ClearContents
          '.AutoFilter
          .EntireColumn.Hidden = False
          Application.Goto .Parent.Range("A1")
     End With
     Proteger

End Sub

Private Sub Masquer()
    Dim k, r1, r2, b, r, r3, cle
    With Range("tabel1").ListObject         'votre tableau
        '.Range.AutoFilter                  'enlever les filtres
        .Range.EntireColumn.Hidden = False     'montrer toutes les colonnes du tableau
        '   .Range.Columns(1).BorderAround LineStyle:=xlContinuous, Weight:=xlThick, ColorIndex:=3

        MFC                                'mettre à jour toutes lesMFCs
        .Range.EntireColumn.Hidden = True  'cacher toutes les colonnes du tableau
        'I = .ListColumns("E_1").Index      'numéro de la Listcolumn "E_1", donc première épreuve
        '.Range.Resize(, I - 1).EntireColumn.Hidden = False     'montrer les listcolumns à partir de la 2eme jusqu'à la colonne avant "épreuve 1"
        ColDeb = Split(Cells(1, N°ColDeb).Address(True, False), "$")(0)
        ColFin = Split(Cells(1, N°ColFin).Address(True, False), "$")(0)
        Columns("A:G").EntireColumn.Hidden = False
        Columns(ColDeb & ":" & ColFin).EntireColumn.Hidden = False

        .Range.Cells(1, .Range.Columns.Count).ColumnWidth = 0.1
        Cnt = 0
        For k = 8 To 1 Step -1            'boucler les checkboxes de 8 à 1
            If Me.Controls("CheckBox" & k).Value = True Then     'il est coché ?
                Cnt = Cnt + 1            'compteur+1
                If k <= 7 Then          'checkbox d'une épreuve
                    r1 = Application.IfError(Application.Match("E_" & k, .HeaderRowRange, 0), 0)
                    If r1 = 0 Then
                        MsgBox "problème avec épreuve " & k
                    Else
                        Exit Sub     'listcolumn début de cette épreuve
                    End If

                    '***********************************************************************************
                    If k <= 3 Or k = 5 Then
                        r2 = Application.IfError(Application.Match("Essai_" & k, .HeaderRowRange, 0), 0)
                        If r2 = 0 Then
                            MsgBox "problème avec Essai " & k
                        Else
                            Exit Sub     'listcolumn fin de cette épreuve
                        End If
                    ElseIf k = 4 Or k >= 6 Then
                        r2 = Application.IfError(Application.Match("Pts_" & k, .HeaderRowRange, 0), 0)
                        If r2 = 0 Then
                            MsgBox "problème avec Pts " & k
                        Else
                            Exit Sub     'listcolumn fin de cette épreuve
                        End If
                    End If
                    '***********************************************************************************

                    r3 = Application.IfError(Application.Match("CLT" & k, .HeaderRowRange, 0), 0)
                    If r3 = 0 Then
                        MsgBox "problème avec CLT" & k
                    Else
                        Exit Sub     'listcolumn du classement de cette épreuve                    Else                     'pour classement général
                    End If
                    r2 = .ListColumns.Count - 1     'listcolumn fin = avant-dernière listcolumn du tableau
                    r1 = r2 - 3         'listcolumn du début = 2 vers gauche
                    r3 = r2 - 1         'listcolumn classement est égal à r2-1
                End If

                .HeaderRowRange.Cells(1, r1).Resize(, r2 - r1 + 1).EntireColumn.Hidden = False     'montrer cette épreuve
                If k = 8 Then
                    Nom_Epreuve = "Classement"
                Else
                    Nom_Epreuve = .HeaderRowRange.Cells(0, r1).Value2     'nom de l'épreuve à utiliser dans le nom du PDF
                End If
                '  sp = Split(.HeaderRowRange.Cells(2, r1).FormulaR1C1, ",") 'formule utilisée pour créer le rang
                '    Cle =iif(sp(ubound(sp)) like "1)*",  xlDescending
                '       Case Else: Cle = xlAscending     'les autres ascending
                '  End Select

                If r3 > 0 Then           'listcolumn "classement" est connue
                    With .Range
                        .Sort .Cells(1, r3), xlAscending, Header:=xlYes     'trier colonne classement "ascendant" ou "descendant"
                    End With
                End If
                .Range.AutoFilter r1, "<>"     'cacher toutes les lignes avec une cellule vide dans la première colonne de cette épreuve
            End If
        Next
    End With
End Sub

Le principe pour chaque checkbox sélectionnée, on relève la colonne de début et la colonne de fin du tableau correspondant à la sélection, ainsi dans la macro "Masquer", il n'y a plus qu'à demander d'afficher cette plage de colonne.

Plus facile pour vous de modifier si le nombre de colonne de chaque activité change.

Cdlt

Bonjour Arturo83 et merci beaucoup

Pour la maintenance et les modifs éventuelles, c'est royal d'avoir détailler les colonnes

Merci d'avoir insisté

Juste, y'a un truc qui est bizarre car selon le code ci-dessous, r3, donc le classement, il devrait être dans l'ordre ascendant. D'autre part le pdf ne devrait afficher que les lignes qui sont non vides dans les colonnes "E_". Or ça n'est plus le cas contrairement au précédent classeur.

  If r3 > 0 Then           'listcolumn "classement" est connue
                    With .Range
                        .Sort .Cells(1, r3), xlAscending, Header:=xlYes     'trier colonne classement "ascendant" ou "descendant"
                    End With
                End If
                .Range.AutoFilter r1, "<>"     'cacher toutes les lignes avec une cellule vide dans la première colonne de cette épreuve
            End If
        Next
    End With
End Sub

Encore merci Arturo83...

Bon appétit, à +

Bonjour,

Intervenir sur le code créé par quelqu'un d'autre n'est pas une bonne idée, car chacun pense différemment. il est certain que si vous demandez à n'importe qui d'intervenir sur le code existant, vous prenez le risque de rencontrer quelques petits problèmes. Il aurait fallu que vous demandiez à la personne qui vous a écrit le code.

De mon côté j'ai essayé de vous apporter une solution par rapport à la question initiale, et qui, comme je l'ai dit auparavant, risque de perturber le fonctionnement déjà correct de la procédure dans son intégralité.

Voici le code modifié de la procédure "Masquer" . Les zones modifiées sont encadrées de lignes d'astérisques.

Private Sub Masquer()
    Dim k, r1, r2, b, r, r3, cle
    With Range("tabel1").ListObject         'votre tableau
        '.Range.AutoFilter                  'enlever les filtres
        .Range.EntireColumn.Hidden = False     'montrer toutes les colonnes du tableau
        '   .Range.Columns(1).BorderAround LineStyle:=xlContinuous, Weight:=xlThick, ColorIndex:=3

        MFC                                'mettre à jour toutes lesMFCs
        .Range.EntireColumn.Hidden = True  'cacher toutes les colonnes du tableau
        'I = .ListColumns("E_1").Index      'numéro de la Listcolumn "E_1", donc première épreuve
        '.Range.Resize(, I - 1).EntireColumn.Hidden = False     'montrer les listcolumns à partir de la 2eme jusqu'à la colonne avant "épreuve 1"
        ColDeb = Split(Cells(1, N°ColDeb).Address(True, False), "$")(0)
        ColFin = Split(Cells(1, N°ColFin).Address(True, False), "$")(0)
        Columns("A:G").EntireColumn.Hidden = False
        Columns(ColDeb & ":" & ColFin).EntireColumn.Hidden = False

        .Range.Cells(1, .Range.Columns.Count).ColumnWidth = 0.1
        Cnt = 0
        For k = 8 To 1 Step -1            'boucler les checkboxes de 8 à 1
            If Me.Controls("CheckBox" & k).Value = True Then     'il est coché ?
                Cnt = Cnt + 1            'compteur+1
                If k <= 7 Then          'checkbox d'une épreuve
                    r1 = Application.IfError(Application.Match("E_" & k, .HeaderRowRange, 0), 0)
                    If r1 = 0 Then
                        MsgBox "problème avec épreuve " & k
                    End If

                    '***********************************************************************************
                    If k <= 3 Or k = 5 Then
                        r2 = Application.IfError(Application.Match("Essai_" & k, .HeaderRowRange, 0), 0)
                        If r2 = 0 Then
                            MsgBox "problème avec Essai " & k
                        End If
                    ElseIf k = 4 Or k >= 6 Then
                        r2 = Application.IfError(Application.Match("Pts_" & k, .HeaderRowRange, 0), 0)
                        If r2 = 0 Then
                            MsgBox "problème avec Pts " & k
                        End If
                    End If
                    '***********************************************************************************

                    r3 = Application.IfError(Application.Match("CLT" & k, .HeaderRowRange, 0), 0)
                    If r3 = 0 Then
                        MsgBox "problème avec CLT" & k
                        Exit Sub     'listcolumn du classement de cette épreuve                    Else                     'pour classement général
                    End If
                    r2 = .ListColumns.Count - 1     'listcolumn fin = avant-dernière listcolumn du tableau
                    r1 = r2 - 3         'listcolumn du début = 2 vers gauche
                    r3 = r2 - 1         'listcolumn classement est égal à r2-1
                End If

                    '***********************************************************************************
                .HeaderRowRange.Cells(1, N°ColDeb).Resize(, N°ColFin - N°ColDeb + 1).EntireColumn.Hidden = False 'montrer cette épreuve
                If k = 8 Then
                    Nom_Epreuve = "Classement"
                Else
                    Nom_Epreuve = .HeaderRowRange.Cells(0, N°ColDeb).Value2     'nom de l'épreuve à utiliser dans le nom du PDF
                End If
                '  sp = Split(.HeaderRowRange.Cells(2, r1).FormulaR1C1, ",") 'formule utilisée pour créer le rang
                '    Cle =iif(sp(ubound(sp)) like "1)*",  xlDescending
                '       Case Else: Cle = xlAscending     'les autres ascending
                '  End Select

                If r3 > 0 Then           'listcolumn "classement" est connue
                    With .Range
                        .Sort .Cells(1, r3), xlAscending, Header:=xlYes     'trier colonne classement "ascendant" ou "descendant"
                    End With
                End If
                .Range.AutoFilter N°ColDeb, "<>"     'cacher toutes les lignes avec une cellule vide dans la première colonne de cette épreuve
                    '***********************************************************************************
            End If
        Next
    End With
End Sub

Bonjour Arturo83 et encore merci

Je comprends tout à fait pour modifier le code d'un autre spécialiste VBA, désolé, mais j'hésite entre 2 car ça avait été fait y'a plusieurs mois sur un autre classeur.

De plus, c'est toujours délicat de demander aux mêmes quand ils m'ont déjà beaucoup beaucoup aidé...

Je viens de m'apercevoir que le format ou la formule de la colonne "E_1" a peut-être été modifié car je ne devrais pas avoir des "zéro" partout :

- Mohamed Fidèle, DUPONT Jean-Claude, entre autres n'ont pas tenté la discipline pétanque 5_ateliers et devraient avoir une cellule vide au lieu du "zéro".

- Les zéros ne devraient s'afficher que lorsqu'un sportif a tenté une discipline mais n'a réussi à faire aucun point.

Pour le classement, il devrait être pris sur la discipline en question et non sur le général.

Ca vient de cet endroit ? Si oui, je ne vois pas ce qui n'est pas correct car r3 est bien égal à "r2 - 1" :

               If r3 > 0 Then           'listcolumn "classement" est connue
                    With .Range
                        .Sort .Cells(1, r3), xlAscending, Header:=xlYes     'trier colonne classement "ascendant" ou "descendant"

Encore désolé pour toutes ces complications...

Voici la version qui fonctionne (c'était il y a 3 jours) :

Encore milles mercis de t'occuper d'une version créée pas d'autres... C'est évidemment bcp plus compliqué

Bonne journée...

Pour le problème des zéros, il suffit de recopier la formule et le format de cellules d'une colonne qui est correcte et de les reporter sur celles de pétanques 5 ateliers(puisqu' apparemment les autres sont correctes)

Pour le classement, vu que que l'on travaille directement avec les numéros de colonnes, il suffit d'appliquer cette méthode ici:

                If N°ColFin > 0 Then            'listcolumn "classement" est connue
                    With .Range
                        .Sort .Cells(1, N°ColFin - 2), xlAscending, Header:=xlYes    'trier colonne classement "ascendant" ou "descendant"
                    End With
                End If

Pour les zéros, je n'avais pas osé le faire pensant que ça entacherait la sélection des lignes excluant celles qui sont vides... Mais ça marche, merci beaucoup

Et merci pour le classement ==> J'arrive bien à déchiffrer ton code, ça coule de source, mais je n'aurais pas été capable de l'écrire

J'ai réussi à affecter la macro "enlever_filtre" par le bouton "Réinitialisation" qui s'exécute à la fin d'un enregistrement d'un PDF pour remettre le tableau en entier

Et en plus ça marche...

J'ai juste un ti souci avec la colonne Classement général puis ça doit être en ordre Ascending aussi :

C'est la colonne "Clt_gene" en "AP" :

 If N°ColFin > 0 Then            'listcolumn "classement" est connue
                    With .Range
                        .Sort .Cells(1, N°ColFin - 2), xlAscending, Header:=xlYes    'trier colonne classement "ascendant" ou "descendant"
                    End With
                End If

En tout cas mille mercis encore

Bonne matinée...

Et bien, il suffit d'affecter le bon décalage, - 1 pour le total (si la colonne de fin est 40 ) et -2 pour le reste (si la colonne de fin est inférieure à 40)

                If N°ColFin > 0 Then            'listcolumn "classement" est connue
                    If N°ColFin < 40 Then decalage = 2 Else decalage = 1
                    With .Range
                        .Sort .Cells(1, N°ColFin - decalage), xlAscending, Header:=xlYes   'trier colonne classement "ascendant" ou "descendant"
                    End With
                End If

N'oubliez pas de déclarer la variable "dim Decalage as string" en début de macro

C'est absolument parfait !!!!! Merci beaucoup pour tout le temps que tu m'as consacré