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

berru76

XLDnaute Occasionnel
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
 

Pièces jointes

  • Essai V3.xlsm
    247.7 KB · Affichages: 3
Solution
Re Bonjour,
Je ne sais si j'ai bien compris, testez le classeur joint
VB:
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("*", ...

berru76

XLDnaute Occasionnel
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
 

Pièces jointes

  • Exemple.PNG
    Exemple.PNG
    58.9 KB · Affichages: 17

fanch55

XLDnaute Barbatruc
Re Bonjour,
Je ne sais si j'ai bien compris, testez le classeur joint
VB:
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 ....
 

Pièces jointes

  • Essai V3.xlsm
    251.7 KB · Affichages: 1
Dernière édition:

berru76

XLDnaute Occasionnel
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
 

Pièces jointes

  • 1.PNG
    1.PNG
    39 KB · Affichages: 17
  • 2.PNG
    2.PNG
    67.7 KB · Affichages: 16
  • 3.PNG
    3.PNG
    21 KB · Affichages: 16
Dernière édition:

berru76

XLDnaute Occasionnel
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
 

Pièces jointes

  • Essai V3 (1).xlsm
    262.3 KB · Affichages: 4

Discussions similaires

Réponses
0
Affichages
222

Statistiques des forums

Discussions
313 287
Messages
2 096 831
Membres
106 758
dernier inscrit
JM9