XL 2016 Modifier ou créer une macro imprimer une sélection de zones

[berru76]

Bonjour

J'utilise une macro pour imprimer une zone de texte selon le nombre de joueurs (Merci a son auteur)

Si c'était possible jusqu'à 60 joueurs dans chaque tour pour les parties doublettes et tètes a tètes d'imprimer sur la même feuille
ou sinon une macro supplémentaire et je rajouterais un bouton

ci joint fichier en exemple

Merci de votre aide

xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Sub SelectionZones()


Dim Sh As Worksheet
Dim rng1 As Range, rng2 As Range, cel As Range
Dim dL%, I%, j%, N%
Dim adr()

adr = Array("AP1:AV60", "AX1:BD36", "AX37:BD56", "BF1:BL36", "BF37:BL56", "BN1:BT36", "BN37:BT56")

Set Sh = Sheets("Triplettes F")
With Sh
For I = 0 To UBound(adr)
Set rng1 = .Range(adr(I))
N = rng1.Rows.Count
dL = N
For j = N To 5 Step -1
If rng1.Cells(j, 3).Value2 = 0 Then dL = dL - 1
Next j

Set rng2 = rng1.Range(Cells(1, 1), Cells(dL, 7))
Call Imples4toursTriplettesF_2(rng2)

Next I
Range("A1").Select
End With
End Sub
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Sub Imples4toursTriplettesF_2(Rng)

Rng.Select
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintSheetEnd
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
Selection.PrintOut Copies:=1, Collate:=True
Range("A1").Select

End Sub

 

[fanch55]

Bonjour,
Vous mélangez les triplettes,doublettes et têtes à têtes ....
Je n'ai pas compris ce que vous voudriez faire ?

 

[berru76]

Bonjour
Je m'excuse je me suis pas bien expliqué
Jusqu'à 54 joueurs afin de ne pas imprimer trop de feuilles
1° tour triplette
tour 2/3/4 comme dans l'exemple ci-joint
si cela est possible
Merci

 

[fanch55]

Re Bonjour,
Je ne sais si j'ai bien compris, testez le classeur joint

Sub SelectionZones()
    Imples4toursTriplettesF_2
End Sub
Sub Imples4toursTriplettesF_2()

    Application.ScreenUpdating = False
    Dim Sh As Worksheet
    Dim First As Range, Last As Range, Lr As Range
    Dim Adr(), Elem As Variant
   
    Sheets("Print").ResetAllPageBreaks
    Sheets("Print").Cells.Delete
   
    Sheets("Triplettes F").Activate
    Columns("AP:BT").EntireColumn.Hidden = False
   
    Adr = Array("AP:AV", "AX:BD", "BF:BL", "BN:BT")
    For Each Elem In Adr
        Set First = Columns(Elem).Find("1°*", , xlValues, xlWhole)
        If Not First Is Nothing Then ' c'est le premier tour
            Set Last = Columns(Elem).Columns(3).Find("*", , xlValues, xlWhole, , xlPrevious)
            Columns(Elem).Resize(Last.Row).Copy
            With Sheets("Print")
                .Activate
                [A1].PasteSpecial xlPasteValues
                [A1].PasteSpecial xlPasteColumnWidths
                [A1].PasteSpecial xlPasteFormats
            End With
        Else
            Sheets("Triplettes F").Activate
            Set Last = Columns(Elem).Columns(3).Find("", Columns(Elem).Columns(3).Rows(4), xlValues, xlWhole, , xlNext)
            Columns(Elem).Resize(Last.Row - 1).Copy
            With Sheets("Print")
                .Activate
                Set Lr = Cells(Cells(Rows.Count, "C").End(xlUp).Offset(1).Row, 1)
                .HPageBreaks.Add Before:=Lr
                Lr.PasteSpecial xlPasteValues
                Lr.PasteSpecial xlPasteColumnWidths
                Lr.PasteSpecial xlPasteFormats
            End With
            Sheets("Triplettes F").Activate
           
            Set First = Columns(Elem).Find("tête*", , xlValues, xlWhole, , xlNext).Offset(-1)
            Set Last = Columns(Elem).Columns(3).Find("*", , xlValues, xlWhole, , xlPrevious)

            Columns(Elem).Rows(First.Row).Resize(1 + Last.Row - First.Row).Copy
            With Sheets("Print")
                .Activate
                Set Lr = Cells(Cells(Rows.Count, "C").End(xlUp).Offset(1).Row, 1)
                Lr.PasteSpecial xlPasteValues
                Lr.PasteSpecial xlPasteColumnWidths
                Lr.PasteSpecial xlPasteFormats
            End With
           
        End If
    Next
    Sheets("Triplettes F").Activate

    Application.ScreenUpdating = True
    With Sheets("Print")
        With .PageSetup
            .PrintArea = "$A:$G"
            .Orientation = xlPortrait
            .PaperSize = xlPaperA4
            .Order = xlDownThenOver
            .LeftMargin = Application.InchesToPoints(0.25)
            .RightMargin = Application.InchesToPoints(0.25)
            .TopMargin = Application.InchesToPoints(0.25)
            .BottomMargin = Application.InchesToPoints(0.25)
            .HeaderMargin = Application.InchesToPoints(0)
            .FooterMargin = Application.InchesToPoints(0)
        End With
        .PrintOut  Preview:=True
    End With
End Sub

Pour Imprimer réellement, commenter le preview:=true ou le mettre à false .

Jusqu'à 54 joueurs afin de ne pas imprimer trop de feuilles

Je ne pense pas que ce soit à l'impression qu'il faille limiter le nombre de joueurs.
La procédure ne fait qu'imprimer ce qu'a fait le tirage ....

 

[berru76]

Bonjour
Excusez moi pour le retour tardif
J'ai testé de nombreuses fois il fonctionne comme j'en aurais besoin si je ne sors pas de la feuille "formées"
je créerai un 1° bouton de 18 a 54 ( avec cette macro ) et un autre de 60 a 96 avec l'autre formule
en temp normal le fichier contient une vingtaine de feuilles et seules sont afficher /noms /mode d'emploi /inscriptions et la feuilles active
Mon problème est que si je reviens sur la feuille inscriptions ou remise a zéro . la feuille "print" disparait. Dans Formées m'affiche les boutons de la feuille inscriptions et ensuite la macro ne fonctionne plus
ci-joint les captures d'écran
voyez vous une solution merci

 

[berru76]

Bonjour
Je pense avoir la solution j'ai rectifié la macro aller Formées et tout fonctionne correctement
Un bouton pour imprimer de 18 A 54
Un bouton pour imprimer de 60 A 96

Un grand merci a vous pour cet excellent travail