Mise en forme d'une impression de tableau

Résolu
TitiPointCom67 Messages postés 38 Statut Membre -  
f894009 Messages postés 17413 Statut Membre -
Bonjour,

J'imprime une liste issue d'une feuille, sous forme de tableau et je me suis servi des macro automatiques pour que mon tableau soit d'un style voulu.
Le problème est que cette macro automatique me donne un nombre de lignes fixe pour la mise en forme, alors que la liste évolue. 

Sub CreerListeInscrits()
    On Error Resume Next
    Dim shListInscrits, shNames
    
    'Localise la feuille 'Liste_Adherents' sheet
    Set shListInscrits = Sheets("Liste_Adherents")
    If Err.Number = 9 Then 'Si pas trouvée
        Set shListInscrits = Sheets.Add(after:=Sheets(Sheets.Count))    'crée la feuille
        shListInscrits.Name = "Liste_Adherents"
    Else
        MsgBox "La feuille 'Liste_Adherents' existe déjà. Supprimez la et relancez la macro.", vbExclamation, "macro CreerListeInscrits"
        Exit Sub
    End If
    
    If vbNo = MsgBox("La macro va créer la liste des adhérents. Cela prendra plusieurs secondes : " & vbCrLf & _
                     "attendez le message de fin avant de continuer à travailler avec Excel. " & vbCrLf & _
                     "Continuer ?", vbYesNo Or vbQuestion, "macro CreerListeInscrits") Then Exit Sub
    
    'Build the header line
    With shListInscrits.Range("A1")
        .Value = "N°"
        .Font.Size = 8
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 4
    End With
    
    With shListInscrits.Range("B1")
        .Range("A1").Value = "Nom"
        .Font.Size = 8
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 10
    End With
    
    With shListInscrits.Range("C1")
        .Value = "Prénom"
        .Font.Size = 8
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 8
    End With
    
    With shListInscrits.Range("D1")
        .Value = "Né le"
        .Font.Size = 8
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 8
    End With
    
    With shListInscrits.Range("E1")
        .Value = "Mail"
        .Font.Size = 8
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 17
    End With
    
    With shListInscrits.Range("F1")
        .Value = "Tel.F"
        .Font.Size = 8
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 9
    End With
    
    With shListInscrits.Range("G1")
        .Value = "Tel.M"
        .Font.Size = 8
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 9
    End With
    
    With shListInscrits.Range("H1")
        .Value = "Adresse"
        .Font.Size = 8
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 15
    End With
    
    With shListInscrits.Range("I1")
        .Value = "CP"
        .Font.Size = 8
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 5
    End With
    
    With shListInscrits.Range("J1")
        .Value = "Ville"
        .Font.Size = 8
        .Font.Bold = True
        .ColumnWidth = 17
    End With
    
    With shListInscrits.Range("K1")
        .Value = "Code1"
        .Font.Size = 8
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 1
    End With
    
    With shListInscrits.Range("L1")
        .Value = "Code2"
        .Font.Size = 8
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 1
    End With
    
    With shListInscrits.Range("M1")
        .Value = "Code3"
        .Font.Size = 8
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 1
    End With
    
    With shListInscrits.Range("N1")
        .Value = "D. Ins."
        .Font.Size = 8
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 6
    End With
    
    shListInscrits.Columns("D:D").NumberFormat = "dd/MM/yyyy"
    shListInscrits.Columns("N:N").NumberFormat = "dd/MM/yyyy"
    
        
    Set shNames = Sheets("INSCRIPTIONS_17-18")
    Dim iRowSrc%, iRowDst%, iNumRawDst%
    iRowDst = 2
    For iRowSrc = 2 To Application.WorksheetFunction.CountA(shNames.Range("A:A")) + 1 'c
        If shNames.Cells(iRowSrc, 1) > 0 Then
            shListInscrits.Range("A" & iRowDst).Font.Size = 6   '
            shListInscrits.Range("A" & iRowDst).HorizontalAlignment = xlCenter
            shListInscrits.Range("A" & iRowDst).Formula = "='INSCRIPTIONS_17-18'!E" & iRowSrc  'numéro
            shListInscrits.Range("B" & iRowDst).Font.Size = 6   '
            shListInscrits.Range("B" & iRowDst).Formula = "='INSCRIPTIONS_17-18'!A" & iRowSrc  'nom
            shListInscrits.Range("C" & iRowDst).Font.Size = 6   '
            shListInscrits.Range("C" & iRowDst).Formula = "='INSCRIPTIONS_17-18'!B" & iRowSrc  'prenom
            shListInscrits.Range("D" & iRowDst).Font.Size = 6   '
            shListInscrits.Range("D" & iRowDst).Formula = "='INSCRIPTIONS_17-18'!F" & iRowSrc  'naisance
            shListInscrits.Range("E" & iRowDst).Font.Size = 6   '
            shListInscrits.Range("E" & iRowDst).Formula = "='INSCRIPTIONS_17-18'!G" & iRowSrc  'Mail
            
            shListInscrits.Range("F" & iRowDst).Font.Size = 6   '
            shListInscrits.Range("F" & iRowDst).HorizontalAlignment = xlCenter
            shListInscrits.Range("F" & iRowDst).NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
            shListInscrits.Range("F" & iRowDst).Formula = "='INSCRIPTIONS_17-18'!H" & iRowSrc  'Tel.F
                If shListInscrits.Range("F" & iRowDst).Value = 0 Then shListInscrits.Range("F" & iRowDst).Value = " " 'Tel.F
            
            shListInscrits.Range("G" & iRowDst).Font.Size = 6   '
            shListInscrits.Range("G" & iRowDst).HorizontalAlignment = xlCenter
            shListInscrits.Range("G" & iRowDst).NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
            shListInscrits.Range("G" & iRowDst).Formula = "='INSCRIPTIONS_17-18'!I" & iRowSrc   'Tel.M
                If shListInscrits.Range("G" & iRowDst).Value = 0 Then shListInscrits.Range("G" & iRowDst).Value = " " 'Tel.M
                
            shListInscrits.Range("H" & iRowDst).Font.Size = 6   '
            shListInscrits.Range("H" & iRowDst).Formula = "='INSCRIPTIONS_17-18'!K" & iRowSrc 'Adresse
            shListInscrits.Range("I" & iRowDst).Font.Size = 6   '
            shListInscrits.Range("I" & iRowDst).HorizontalAlignment = xlCenter
            shListInscrits.Range("I" & iRowDst).Formula = "='INSCRIPTIONS_17-18'!L" & iRowSrc 'CP
            shListInscrits.Range("J" & iRowDst).Font.Size = 6   '
            shListInscrits.Range("J" & iRowDst).Formula = "='INSCRIPTIONS_17-18'!M" & iRowSrc 'Ville
            
            shListInscrits.Range("K" & iRowDst).Font.Size = 6   '
            shListInscrits.Range("K" & iRowDst).HorizontalAlignment = xlCenter
            shListInscrits.Range("K" & iRowDst).Formula = "='INSCRIPTIONS_17-18'!N" & iRowSrc 'Code1
                If shListInscrits.Range("K" & iRowDst).Value = 0 Then shListInscrits.Range("K" & iRowDst).Value = " "
               
            shListInscrits.Range("L" & iRowDst).Font.Size = 6   '
            shListInscrits.Range("L" & iRowDst).HorizontalAlignment = xlCenter
            shListInscrits.Range("L" & iRowDst).Formula = "='INSCRIPTIONS_17-18'!O" & iRowSrc 'Code2
                If shListInscrits.Range("L" & iRowDst).Value = 0 Then shListInscrits.Range("L" & iRowDst).Value = " "
                
            shListInscrits.Range("M" & iRowDst).Font.Size = 6   '
            shListInscrits.Range("M" & iRowDst).HorizontalAlignment = xlCenter
            shListInscrits.Range("M" & iRowDst).Formula = "='INSCRIPTIONS_17-18'!P" & iRowSrc 'Code3
            If shListInscrits.Range("M" & iRowDst).Value = 0 Then shListInscrits.Range("M" & iRowDst).Value = " "
            
            shListInscrits.Range("N" & iRowDst).Font.Size = 6   '
            shListInscrits.Range("N" & iRowDst).HorizontalAlignment = xlCenter
            shListInscrits.Range("N" & iRowDst).Formula = "='INSCRIPTIONS_17-18'!T" & iRowSrc 'D.Ins.
                
            shListInscrits.Range("A" & iRowDst).RowHeight = 12
           
            iRowDst = iRowDst + 1
        End If
    Next
    
    'Trie la liste
    Selection.Sort Key1:=shListInscrits.Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
    shListInscrits.Activate
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
          
    ActiveWindow.FreezePanes = True


PARTI FAITE A L'AIDE DES MACRO AUTO 

 
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$N$150"), , xlYes).Name = "Tableau4"
    Range("Tableau4[#All]").Select
    ActiveSheet.ListObjects("Tableau4").TableStyle = "TableStyleLight1"
    Range("A2").Select


SUITE DU CODE 

iNumRawDst = Application.WorksheetFunction.CountA(shListNo.Range("A:A"))
    
    With shListInscrits.PageSetup
        .LeftHeader = ""
        .CenterHeader = "&08 Liste des adhérents par noms au &D à &T"
        .RightHeader = ""
        .LeftFooter = ""
        .RightFooter = ""
        .CenterFooter = "&08 Page &P de &N"
        .Orientation = xlLandscape
        .PaperSize = xlPaperA4
        .HeaderMargin = Application.CentimetersToPoints(1)   '
        .FooterMargin = Application.CentimetersToPoints(1)   '
        .TopMargin = Application.CentimetersToPoints(1.5)    '
        .BottomMargin = Application.CentimetersToPoints(1.5) '
        .RightMargin = Application.CentimetersToPoints(1)    '
        .LeftMargin = Application.CentimetersToPoints(1)     '
    End With

    Sheets("TABLEAU_DE_BORD").Select
    Cells(4, 29).Value = 1
    Cells(4, 32).Font.Size = 12
    Cells(4, 32).Font.Bold = True
    Cells(4, 32).Value = "  Liste créée le " & Date & " à " & Time
    Cells(1, 1).Select
    Cells(1, 1).Activate
    Sheets("Liste_Adherents").Select
    If vbNo = MsgBox("Liste correctement créée. " & iNumRawDst - 1 & " noms ajoutés." & vbCrLf & "La feuille est concue pour " & _
           "être imprimée sur du papier A4 en mode paysage. Voulez-vous l'imprimer ?", vbYesNo Or vbQuestion, "macro CreerListeInscrits") Then Exit Sub Else ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
    
End Sub


Quelqu'un peut-il me dire comment faire pour que cette mise en forme s'applique à la totalité du tableau quelque soit sa longueur.
Je précise que je ne suis pas très doué pour le VBA que je comprend vite mais qu'il faut parfois m'expliquer longtemps.
Merci d'avance
A voir également:

1 réponse

Réponse 1 / 1
f894009 Messages postés 17413 Statut Membre 1 715
 
Bonjour, 

'PARTI FAITE A L'AIDE DES MACRO AUTO
    'derniere ligne du tableau
    derlig = Cells.Find("*", , , , xlByRows, xlPrevious).Row
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$N$" & derlig), , xlYes).Name = "Tableau4"
    Range("Tableau4[#All]").Select
    ActiveSheet.ListObjects("Tableau4").TableStyle = "TableStyleLight1"
    Range("A2").Select
0
TitiPointCom67 Messages postés 38 Statut Membre
 
Bonjour,
Merci, mais ...
Ca ne fonctionne pas, le tableau est créé mais la mise en forme ne se fait pas.
0
f894009 Messages postés 17413 Statut Membre 1 715 > TitiPointCom67 Messages postés 38 Statut Membre
 
Re,
Chez moi ca marche

fait avec votre fichier: https://mon-partage.fr/f/8tIdU4dc/
0

Discussions similaires

Excel supprimer une mise en forme de tableau
pépé35530 -
allezlom -

24 réponses