XL 2016 Passer à la page suivante automatiquement

Dranreb

XLDnaute Barbatruc
Mettez vos listes sous forme de tableaux dans Excel ça vaudra mieux. C'est pas normal que la UsedRange de votre feuille ait autant de lignes.
D'ailleurs TE n'a pas été rechargé à partir d'une autre source pour le dernier tableau ?
 

bennp

XLDnaute Occasionnel
J'ai créé les 2 tableaux comme demandé, d'ailleurs dans mon fichier réel, ils ont des noms définis.
Par contre je vois pas de changement. voici mon fichier en pièce jointe.

il est vrai qu'il y a beaucoup de lignes. j'ai copié /collé les tableaux et je remarque que plus on lance la macro, plus il y a de lignes qui s'ajoutent... (les tableaux ne se mettent plus à la page suivante)

merci
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
Et bien alors faites TE = Feuil1.ListObjects(1).Range.Value tout simplement.
Est-ce normal que ce contenu du tableau TE reste le même pour les outils ?

J'ai bien l'impression qu'il manque un TE = Feuil3.ListObjects(1).Range.Value
(Feuil3 c'est le nom de l'objet Worksheet de la rubrique Microsoft Excel Objets qui assume la représentation auprès de VBA de la feuille Excel nommée "Feuil4")
 
Dernière édition:

bennp

XLDnaute Occasionnel
Non justement le contenu est complètement différent j'ai bien changé avec TE = Feuil1.ListObjects(1).Range.Value pour le 1er tableau et ajouté TE = Feuil3.ListObjects(1).Range.Value pour le 2ème tableau. Dailleurs comment vous savez que c'est Feuil3 qui représente Feuil4, où trouver cette information ?

Mon 2ème tableau n'est pas correctupload_2018-1-19_20-38-12.png


il devrait être comme ça :

upload_2018-1-19_20-46-45.png

J'ai aussi toujours un problème de saut de page. Pourtant j'ai fait une fusion de lignes comme vous me l'avez conseillez. Ce qui est bizarre c'est que je l'avais plus jusqu'à ce que je copie/colle sur une nouvelle feuille pour supprimer les lignes vides inutiles (d'ailleurs elles sont revenues).

Voici le code :

VB:
Option Explicit

Sub TableauParoi() ' Le blanc souligné est à réserver aux noms des procédures évènements
                   ' comme séparateur entre le nom de l'objet et le nom de l'évènement.
Dim TE(), LE&, TS(), LS&, TR(), LR&, C&, Nom As String, Rng As Range, LTot&

TE = Feuil1.ListObjects(1).Range.Value
ReDim TS(1 To 1000, 1 To 5)

For LE = 2 To UBound(TE, 1)
   If Not IsEmpty(TE(LE, 2)) Then
      LS = LS + 1
      TS(LS, 1) = TE(LE, 1)
      TS(LS, 2) = TE(LE, 2): End If
   If Not IsEmpty(TE(LE, 3)) Then TS(LS, 3) = TE(LE, 3) * 100
   If Not IsEmpty(TE(LE, 4)) Then TS(LS, 4) = TE(LE, 4)
   If Not IsEmpty(TE(LE, 5)) Then TS(LS, 5) = TE(LE, 5)
  
   Next LE
'ReDim TR(1 To 1000, 1 To 25)
ReDim TR(1 To UBound(TE, 1), 1 To 25)
InitialiserMiseEnPage Feuil2.[C134], 39, 5
LS = 1
Do: Nom = TS(LS, 1): TR(1, 1) = UCase(Nom)
  
   LR = 3: For C = 1 To 4
      TR(LR, Choose(C, 1, 23, 24, 25)) = Choose(C, "Fruit", "épaisseur (cm)", "Chiffre", "Clé")
      Next C
   Do: LR = LR + 1
      For C = 1 To 4
         TR(LR, Choose(C, 1, 23, 24, 25)) = TS(LS, C + 1)
         Next C
      LS = LS + 1: Loop Until TS(LS, 1) <> Nom
    Set Rng = PlageSuivante(TR, LR)
    LTot = Rng.Rows.Count + 1
    With Rng(LTot, 20)
    .Value = "  TOTAL"
    .Font.Bold = True
    End With
    Rng(LTot, 20).Resize(, 3).BorderAround ColorIndex:=16
    Rng(LTot, 23).FormulaR1C1 = "=SUM(R[-" & LTot - 4 & "]C:R[-1]C)"
    Rng(LTot, 24).FormulaR1C1 = "=SUM(R[-" & LTot - 4 & "]C:R[-1]C)"
    Rng(LTot, 25).FormulaR1C1 = "=SUM(R[-" & LTot - 4 & "]C:R[-1]C)"
   
    With Rng(2, 1).Resize(2, 22)
    .MergeCells = True
    End With
    With Rng(2, 23).Resize(2)
    .MergeCells = True
    .HorizontalAlignment = xlCenter
    End With
    With Rng(2, 24).Resize(2)
    .MergeCells = True
    .HorizontalAlignment = xlCenter
    End With
    With Rng(2, 25).Resize(2)
    .MergeCells = True
    .HorizontalAlignment = xlCenter
    End With
   
    With Rng.Rows(2).Resize(2)
        '.RowHeight = 30
        .Interior.Color = RGB(186, 255, 186)
        .VerticalAlignment = xlCenter
        .BorderAround ColorIndex:=16
    End With
   
    Rng(LTot, 20).Resize(, 3).Interior.Color = RGB(186, 255, 186)
    With Rng(3, 23).Resize(LTot - 2, 3)
        .NumberFormat = "0.00"
        .HorizontalAlignment = xlCenter
    End With
    Rng.Rows(4).Resize(LTot - 4).BorderAround ColorIndex:=16
    Rng(4, 22).Resize(LTot - 4, 4).Borders(xlInsideVertical).ColorIndex = 16
    Rng(LTot, 23).Resize(, 3).BorderAround ColorIndex:=16
    Rng(1, 1).Font.Bold = True
   Loop Until IsEmpty(TS(LS, 1))
   'ReDim TR(1 To UBound(TE, 1), 1 To 25)
   TE = Feuil3.ListObjects(1).Range.Value
   LE = 1
    Do:
    TR(1, 1) = UCase("Liste des outils")
    LR = 5: For C = 1 To 4
      TR(LR, Choose(C, 1, 21, 24, 25)) = Choose(C, "Outil", "position", "taille", "couleur")
      Next C
      Do: LR = LR + 1
      For C = 1 To 4
         TR(LR, Choose(C, 1, 21, 24, 25)) = TE(LE, C)
         Next C
      LE = LE + 1: Loop Until LE > UBound(TE, 1)
     
    Set Rng = PlageSuivante(TR, LR)
    LTot = Rng.Rows.Count + 1

   
    With Rng(4, 1).Resize(2, 18)
    .MergeCells = True
    End With
    With Rng(4, 19).Resize(2, 5)
    .MergeCells = True
    .HorizontalAlignment = xlCenter
    End With
    With Rng(4, 24).Resize(2)
    .MergeCells = True
    .HorizontalAlignment = xlCenter
    End With
    With Rng(4, 25).Resize(2)
    .MergeCells = True
    .HorizontalAlignment = xlCenter
    End With

 
    With Rng.Rows(4).Resize(2)
    .Interior.Color = RGB(186, 255, 186)
    .VerticalAlignment = xlCenter
    .BorderAround ColorIndex:=16
    End With
   
    With Rng(6, 19).Resize(LTot - 2, 7)
        .NumberFormat = "0.00"
        .HorizontalAlignment = xlCenter
    End With
    Rng.Rows(4).Resize(LTot - 4).BorderAround ColorIndex:=16
    Rng(6, 24).Resize(LTot - 6, 2).Borders(xlInsideVertical).ColorIndex = 16
    Rng(6, 19).Resize(LTot - 6, 5).BorderAround ColorIndex:=16
    With Rng(1, 1)
    .Font.Bold = True
    .Font.Color = RGB(20, 127, 127)
    End With
   Loop Until UBound(TE, 1)
TerminerMiseEnPage
'Call TableauOutil
End Sub
je vous joins aussi mon fichier au cas où

Merci de votre aide
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
On trouve cette information là :
upload_2018-1-19_22-47-21.png

Faites un Redim aussi de TR pour effacer ce qui y avait été mis pour les 1ers tableaux.
 

bennp

XLDnaute Occasionnel
Je souhaiterai faire 2 tableaux différents à partir des mêmes données (dont 1 colonnes en commun). Dois je repasser une des variables intermédiaires (mes informations de base ne seront pas forcement au même endroit dans mon tableau).

Par exemple :
upload_2018-1-30_15-51-14.png

Ne pas faire apparaître la colonne Position. J'ai essayé de créer 2 boucles For C = 1 To 1 puis For C = 3 To 4 mais ça ne fonctionne pas...

je joins le fichier au cas ou

merci pour votre aide
 

Dranreb

XLDnaute Barbatruc
Bonjour.
Oh, il ne reste que 3 info à ventiler alors ne faites plus de boucle mais 3 affectations TR(LR, 1) = TE(LE, 1): TR(LR, 25) = TE(LE, 3): TR(LR, 26) = TE(LE, 4)
 

bennp

XLDnaute Occasionnel
je dois néanmoins le remplacer par quelque chose ?
Code:
For LE = 2 To UBound(TE, 1)
   If Not IsEmpty(TE(LE, 2)) Then
      LS = LS + 1
        TS(LS, 1) = TE(LE, 1)
        TS(LS, 2) = TE(LE, 2)
        TS(LS, 3) = TE(LE, 3)
        TS(LS, 4) = TE(LE, 4): End If
   Next LE
ou celui là ?

VB:
Do: Nom = TS(LS, 1): TR(1, 1) = UCase(Nom)
   LR = 3: For C = 1 To 4
      TR(LR, Choose(C, 1, 20, 24, 25)) = Choose(C, "Outil", "position", "taille", "couleur")
      Next C
   Do: LR = LR + 1
      For C = 1 To 4
         TR(LR, Choose(C, 1, 20, 24, 25)) = TS(LS, C + 1)
         Next C
      LS = LS + 1: Loop Until TS(LS, 1) <> Nom
Et si j'ai des données espacée ?

upload_2018-1-30_21-38-27.png

Je dois pour le coup passer par des variables intermédiaires ? ou juste If Notempty suffit (j'ai d'ailleurs testé mais ça ne fonctionne pas)

Merci
 

Dranreb

XLDnaute Barbatruc
Je n'y comprend plus rien. Sont-ce les outils que vous voulez aussi sortir sans la position ou bien autre chose ?
Évitez d'avoir des données espacées, vous voyez bien que ça complique tout en obligeant à faire un tableau intermédiaire sans espacement.
 

bennp

XLDnaute Occasionnel
Le problème est que mes tableaux sont importés de fichiers xml et donc ne peuvent pas être modifiés. J'ai trouvé une solution avec une macro qui remonte toutes les informations avant (je pense pas que ça prenne plus de temps.

Je voudrais aussi copier coller un tableau. J'ai réussi à le faire :

VB:
Sub copier_graph()
    ActiveSheet.ChartObjects(1).Delete
    Worksheets("Feuil6").ChartObjects("Graph_vitrage").Activate
    ActiveChart.ChartArea.Copy
    ActiveSheet.Paste Destination:=Worksheets("Feuil2").Range("B183")
    ActiveSheet.ChartObjects(1).Name = "Graph_vitrage"
End Sub
Le problème est de l'intégrer maintenant dans la macro existante, j'ai testé ça mais bon... comme d'habitude, ça fonctionne pas :

VB:
TE = Feuil6.ChartsObjects(1).Range.Value
    ReDim TR(1 To 100, 1 To 26)
    Worksheets("Feuil6").ChartObjects("Graph_vitrage").Activate
    ActiveChart.ChartArea.Copy
    Set Rng = PlageSuivante(TR, LR)
    LR = 5
    ActiveSheet.Paste
Une idée ?

Merci
 

bennp

XLDnaute Occasionnel
J'ai testé ça :

VB:
    InitialiserMiseEnPage Feuil1.[B128], 40, 5
    Worksheets("Graphique vitrage").ChartObjects("Graphique 1").Activate
    ActiveChart.ChartArea.Copy
   
    Feuil1.Select
    LR = 1
    'TR(1, 1).Select
    'Set Rng = PlageSuivante(TR, LR)
    'Rng(1, 1).Select
   
    ActiveSheet.Paste
   
    'Destination:=Worksheets("Rapport").Range("B183")
    ActiveSheet.ChartObjects(1).Name = "Graphique 1"
J'ai essayé avec le Set Rng = PlageSuivante(TR, LR)

Du coup, j'arrive à coller le graphique mais il est pas très bien placé mais je n'arrive pas à l’intégrer à la suite de mes tableaux
 

Dranreb

XLDnaute Barbatruc
Ah c'est le graphique lui même que vous voulez insérer !
Essayez Worksheets("Graphique vitrage").ChartObjects("Graphique 1").Copy Destination:=PlageSuivante(TR, LR)
 

bennp

XLDnaute Occasionnel
bonjour,

ça n'a pas l'air de fonctionner, je ne sais pas pourquoi ?
J'ai intégré ce code à la fin avant TerminerMisEenPage :
VB:
 Worksheets("Feuil8").ChartObjects("Graphique 2").Copy Destination:=PlageSuivante(TR, LR)
   
    LR = 1
    ActiveSheet.Paste
   
    'Destination:=Worksheets("Rapport").Range("B183")
    ActiveSheet.ChartObjects(1).Name = "Graphique 2"
ça bug à la 1ère ligne... Par contre je remarque que mon dernier tableau a bien été inséré mais sans mise en forme.

Merci
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
Bonjour.
Simplifiez la constitution du TR pour les outils :
VB:
Rem. — Outils
TE = Feuil3.ListObjects(1).Range.Value
ReDim TR(1 To UBound(TE, 1) + 5, 1 To 26)
TR(1, 1) = UCase("Liste des outils")
For C = 1 To 4
   TR(4, Choose(C, 1, 24, 25, 26)) = Choose(C, "Outil", "position", "taille", "couleur")
   Next C
LR = 5
For LE = 1 To UBound(TE, 1)
   LR = LR + 1
   For C = 1 To 4
      TR(LR, Choose(C, 1, 24, 25, 26)) = TE(LE, C)
      Next C, LE
Set Rng = PlageSuivante(TR, LR)
Et pour le graphique, le paramètre Destination n'étant pas supporté :
VB:
rem. — Graphique
ReDim TR(1 To 12, 1 To 26)
Set Rng = PlageSuivante(TR, 12)
Feuil8.ChartObjects("Graphique 2").Copy
Rng(1, 1).PasteSpecial
 
Dernière édition:

bennp

XLDnaute Occasionnel
Bonjour,
je relance la discussion, j'essaie de finaliser mon fichier ! J'ai rajouté un bout de code, juste un copié collé, ça fonctionne parfaitement mais la zone d'impression ne se recalcule pas bien et du coup il me manque un bout de texte :

VB:
   ReDim TR(1 To 100, 1 To 26)
  
    LE = 2
   Set Rng = PlageSuivante(TR, LR)
   LTot = Rng.Rows.Count + 1
  
    Range("AC5:BB24").Copy Rng(LTot + 4, 1)
   'Rng(1, 1).Resize(18, 27).Paste
  
    Range("BA8:BB11").Copy
    Rng(LTot + 7, 25).PasteSpecial xlPasteValues

TerminerMiseEnPage
  
End Sub
J'ai essayé aussi sans utiliser le Ltot mais ça ne fonctionne pas. Je ne vois pas ce qui pourrait faire en sorte que la zone d'impression soit bien calculée...

Un idée svp ?

Merci
 

Dranreb

XLDnaute Barbatruc
Bonjour
Oh, c'est une histoire ancienne, ça.
Je pense que vous devez mettre à jour LCou du nombre de lignes collées.
 

Dranreb

XLDnaute Barbatruc
Bon il y a trop de choses, je ne sais pas où est ce code.
Au lieu de Range("AC5:BB24").Copy ne pourriez vous faire TRés = Range("AC5:BB24").Value
puis Set Rng = PlageSuivante(TRés, Ubound(TRés,1))
Comme ça ça entrerait dans le cadre du suivi automatique du remplissage pour que le TerminerMiseEnPage définisse correctement la zone d'impression à la fin, là où il en est arrivé ?
Parce qui si vous faites des choses en douce en dehors de de sa gestion, comment voulez vous qu'il puisse définir une zone d'impression qui l'englobe ?
 
Dernière édition:

Discussions similaires


Haut Bas