Excel-->PPT saut page et titre colonnes

**fidecourt** · 01/02/2011, 13h38

bonjour,

besoin d'aide pour pofiner cette macro
je voudrais :

insérer dans la première ligne le titre des colonnes
générer 1 nouveau slide quand la page contient plus de 20 lignes
insérer dans la première ligne le titre des colonnes

sachant que dans certaines cellules j'ai plusieurs lignes

j'ai repris la macro qui fonctionne pour une autre feuille mais là, ça bloque
je dois mal interprêté le code

voici le code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
Option Explicit
Sub PPTlisteAgrSautPage()
'source : forum Developpez.com Auteur : Qwazerty
'insertion du code Devis qui fonctionne avec sauts de pages et test adaptation
'==============================================================================
Dim objPPT As PowerPoint.Application
Dim objPres As PowerPoint.Presentation
Dim objSld As PowerPoint.Slide
Dim objShp As PowerPoint.Shape
Dim ObjShTable As PowerPoint.Shape
Dim Tablo As Variant
Dim x As Integer, i As Integer, y As Integer
Dim TheRow As PowerPoint.Row
Dim NomTableau As String
Dim NewTop As Integer
Dim TheShTab As PowerPoint.Shape
Dim TmpTop As Integer
Dim NbrLigne As Byte
Dim AskNewSlide As Boolean, SameTableau As Boolean
Const cstNbrMaxLigne As Byte = 10
Dim NbrLigneAdded As Byte
Dim sTitre As String
 
 
With Sheets("AgrementsListeTriee")
    Tablo = .Range("A2:Z" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
 
Set objPPT = CreateObject("Powerpoint.Application")
objPPT.Visible = True
 
 
Set objPres = objPPT.Presentations.Add
objPres.SaveAs ThisWorkbook.Path & "\Agrements.pptx"
 
'On charge le modele
objPres.ApplyTemplate ThisWorkbook.Path & "\ListeAgr1.potx"
 
For i = 1 To UBound(Tablo)
    'On regarde le nombre de lignes qui devront etre rajoutées au tableau
    If Tablo(i, 1) <> "" Then NbrLigneAdded = 1
    NomTableau = "Liste récapitulative des agréments"
    AskNewSlide = CBool(NbrLigne + NbrLigneAdded > cstNbrMaxLigne)
    'SameTableau = CBool(NomTableau = Tablo(i, 2))
    'On regarde si on doit créer un nouveau Slide ou completer l'existant
    'If Not SameTableau Or AskNewSlide Then
    If AskNewSlide Then
        'RéInit
        NbrLigne = 0
 
        'sTitre = "Liste récapitulative des agréments"
        'On garde en memoire le nom du tableau si celui-ci a change
        'If Not SameTableau Then
            NomTableau = "Liste récapitulative des agréments"
 
 
        'Else
            If AskNewSlide Then NomTableau = NomTableau
        End If
 
 
        'On ajoute un nouveau Slide
        Set objSld = objPres.Slides.AddSlide(objPres.Slides.Count + 1, objPres.SlideMaster.CustomLayouts(6))
 
        'On renseigne le titre du slide
        objSld.Shapes.Title.TextFrame.TextRange.Text = NomTableau
        objSld.Shapes.Title.TextFrame.TextRange.Font.Name = "brush script std"
        objSld.Shapes.Title.TextFrame.TextRange.Font.Size = 20
 
    'On crée le tableau qui contiendra les données avec 1 lignes 7 colonnes
    Set ObjShTable = objSld.Shapes.AddTable(NbrLigneAdded, 7)
 
 
    'On ajoute le nombre de ligne à ajouter au total de ligne du tableau
    NbrLigne = NbrLigne + NbrLigneAdded
 
    'On formate le tableau avec un style vierge
    ObjShTable.Table.ApplyStyle "{2D5ABB26-0587-4C30-8999-92F81FD0307C}", True
 
    With ObjShTable
        .Left = 35
        .Top = 100
    End With
 
 
    'On regarde si des objet tableau existe et on le rajoute a la suite du plus bas
 
 
 
  'NewTop = ObjShTable.Top
    'For Each TheShTab In objSld.Shapes
        'If TheShTab.HasTable And (TheShTab.Name <> ObjShTable.Name) Then
            'TmpTop = TheShTab.Top + TheShTab.Height
            'If NewTop < TmpTop Then NewTop = TmpTop + 3
        'End If
    'Next
    'ObjShTable.Top = NewTop
 
 
 
 
 
 
'===============
'rajout du code liste qui fonctionne sans saut page :
For Each objShp In objSld.Shapes
 
        If objShp.HasTable Then
 
            With objShp.Table
 
                Do
                If Tablo(i, 1) <> "" Then
                       .Rows.Add
 
     'On dimensionne la taille des colonnes
    With ObjShTable.Table
        .Columns(1).Width = 130 'designation
        .Columns(2).Width = 50  'calibre
        .Columns(3).Width = 100 'agrement
        .Columns(4).Width = 200 'dénomination
        .Columns(5).Width = 50  'catégorie
        .Columns(6).Width = 50  'distance
        .Columns(7).Width = 60  'actif
 
 
    'On Rajoute les données
        'pour chaque cellule, on aligne le texte, on détermine la taille de police, on remplit avec les données :
 
        .Cell(1 + (1 * x), 1).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
        .Cell(1 + (1 * x), 1).Shape.TextFrame.TextRange.Font.Size = 12
        .Cell(1 + (1 * x), 1).Shape.TextFrame.TextRange.Text = Tablo(i, 2) 'désignation
        .Cell(1 + (1 * x), 2).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
        .Cell(1 + (1 * x), 2).Shape.TextFrame.TextRange.Text = Tablo(i, 3) 'calibre
        .Cell(1 + (1 * x), 2).Shape.TextFrame.TextRange.Font.Size = 12
        .Cell(1 + (1 * x), 3).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
        .Cell(1 + (1 * x), 3).Shape.TextFrame.TextRange.Text = (Tablo(i, 7) & "   " & Tablo(i, 10) & "   " & Tablo(i, 12) & "   " & Tablo(i, 14) & "   " & Tablo(i, 16)) 'Agrément1 Col F
        .Cell(1 + (1 * x), 3).Shape.TextFrame.TextRange.Font.Size = 12
        .Cell(1 + (1 * x), 4).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
        .Cell(1 + (1 * x), 4).Shape.TextFrame.TextRange.Text = Tablo(i, 9) 'dénomination
        .Cell(1 + (1 * x), 4).Shape.TextFrame.TextRange.Font.Size = 12
        .Cell(1 + (1 * x), 5).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
        .Cell(1 + (1 * x), 5).Shape.TextFrame.TextRange.Text = Tablo(i, 4) 'catégorie
        .Cell(1 + (1 * x), 5).Shape.TextFrame.TextRange.Font.Size = 12
        .Cell(1 + (1 * x), 6).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
        .Cell(1 + (1 * x), 6).Shape.TextFrame.TextRange.Text = (Tablo(i, 11) & "       " & Tablo(i, 13) & "       " & Tablo(i, 15) & "       " & Tablo(i, 17)) 'distance1 Col K=11
        .Cell(1 + (1 * x), 6).Shape.TextFrame.TextRange.Font.Size = 12
        .Cell(1 + (1 * x), 7).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
        .Cell(1 + (1 * x), 7).Shape.TextFrame.TextRange.Text = Format(Tablo(i, 5), "# ##0.000") 'actif
        .Cell(1 + (1 * x), 7).Shape.TextFrame.TextRange.Font.Size = 12
 
        End With
        End If
 
                    i = i + 1
                    x = x + 1
                    If i > UBound(Tablo) Then Exit Do
                Loop While Tablo(i, 1) <> ""
 
    End With
End If
Next
Next
objPres.Save
'objPres.Close
End Sub

==================
où est l'erreur ?
je joins le fichier :
http://www.cijoint.fr/cjlink.php?fil...ijJ5MvyY4.xlsm

merci pour votre aide !

**Qwazerty** · 01/02/2011, 18h58

Salut
Bon je t'ai commenté 2 / 3 trucs, l'ensemble est un peu confus, la première partie tu as 95% du code qui effectue des choses qui ne sont pas utilisées plus loin dans le code.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
Option Explicit
Sub PPTlisteAgrSautPage()
'source : forum Developpez.com Auteur : Qwazerty
'insertion du code Devis qui fonctionne avec sauts de pages et test adaptation
'==============================================================================
Dim objPPT As PowerPoint.Application
Dim objPres As PowerPoint.Presentation
Dim objSld As PowerPoint.Slide
Dim objShp As PowerPoint.Shape
Dim ObjShTable As PowerPoint.Shape
Dim Tablo As Variant
Dim x As Integer, i As Integer, y As Integer
Dim TheRow As PowerPoint.Row
Dim NomTableau As String
Dim NewTop As Integer
Dim TheShTab As PowerPoint.Shape
Dim TmpTop As Integer
Dim NbrLigne As Byte
Dim AskNewSlide As Boolean, SameTableau As Boolean
Const cstNbrMaxLigne As Byte = 10
Dim NbrLigneAdded As Byte
Dim sTitre As String
 
 
With Sheets("AgrementsListeTriee")
    Tablo = .Range("A2:Z" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
 
Set objPPT = CreateObject("Powerpoint.Application")
objPPT.Visible = True
 
 
Set objPres = objPPT.Presentations.Add
objPres.SaveAs ThisWorkbook.Path & "\Agrements.pptx"
 
'On charge le modele
'objPres.ApplyTemplate ThisWorkbook.Path & "\ListeAgr1.potx"
 
For i = 1 To UBound(Tablo)
    'On regarde le nombre de lignes qui devront etre rajoutées au tableau
    'Tablo(i,1) ne peut jamais etre vide, puisque tu te sert de cette colonne pour definir la taille de ton tableau
    'If Tablo(i, 1) <> "" Then
    NbrLigneAdded = 1
    'NomTableau = "Liste récapitulative des agréments" '?? c'est utilisé num part
 
    AskNewSlide = CBool(NbrLigne + NbrLigneAdded > cstNbrMaxLigne)
    'SameTableau = CBool(NomTableau = Tablo(i, 2))
    'On regarde si on doit créer un nouveau Slide ou completer l'existant
    'If Not SameTableau Or AskNewSlide Then
    If AskNewSlide Then
        'RéInit
        NbrLigne = 0
 
        'sTitre = "Liste récapitulative des agréments"
        'On garde en memoire le nom du tableau si celui-ci a change
        'If Not SameTableau Then
'            NomTableau = "Liste récapitulative des agréments"'?? c'est utilisé num part
 
 
        'Else
'            If AskNewSlide Then NomTableau = NomTableaut '?? quel interet
    End If
 
 
        'On ajoute un nouveau Slide
        Set objSld = objPres.Slides.AddSlide(objPres.Slides.Count + 1, objPres.SlideMaster.CustomLayouts(6))
 
        'On renseigne le titre du slide
        objSld.Shapes.Title.TextFrame.TextRange.Text = "Liste récapitulative des agréments" 'NomTableau
        objSld.Shapes.Title.TextFrame.TextRange.Font.Name = "brush script std"
        objSld.Shapes.Title.TextFrame.TextRange.Font.Size = 20
 
    'On crée le tableau qui contiendra les données avec 1 lignes 7 colonnes
    Set ObjShTable = objSld.Shapes.AddTable(1, 7) 'NbrLigneAdded inutile d'utiliser une variable si tu as toujours qu'une ligne a rajouter
 
 
    'On ajoute le nombre de ligne à ajouter au total de ligne du tableau
    NbrLigne = NbrLigne + 1 'NbrLigneAdded
 
    'On formate le tableau avec un style vierge
    ObjShTable.Table.ApplyStyle "{2D5ABB26-0587-4C30-8999-92F81FD0307C}", True
 
    With ObjShTable
        .Left = 35
        .Top = 100
    End With
 
 
    'On regarde si des objet tableau existe et on le rajoute a la suite du plus bas
 
 
 
  'NewTop = ObjShTable.Top
    'For Each TheShTab In objSld.Shapes
        'If TheShTab.HasTable And (TheShTab.Name <> ObjShTable.Name) Then
            'TmpTop = TheShTab.Top + TheShTab.Height
            'If NewTop < TmpTop Then NewTop = TmpTop + 3
        'End If
    'Next
    'ObjShTable.Top = NewTop
 
 
 
 
 
 
'===============
'rajout du code liste qui fonctionne sans saut page :
 
'Pourquoi tu n'utilises plus ton objet table ? ObjShTable il represente ton tableau, tu n'as donc pas besoin de tester tous les Objet de ta feuille
For Each objShp In objSld.Shapes
 
        If objShp.HasTable Then
 
            With objShp.Table
 
                Do
                If Tablo(i, 1) <> "" Then 'Il ne sera jamais vide voir remarque plus haut
                       .Rows.Add
 
     'On dimensionne la taille des colonnes
'Ton formatage de colonne doit se faire avant la boucle, il est fait une fois pour toute, pas la peinne de le refaire a chaque ajout de ligne
    With ObjShTable.Table
        .Columns(1).Width = 130 'designation
        .Columns(2).Width = 50  'calibre
        .Columns(3).Width = 100 'agrement
        .Columns(4).Width = 200 'dénomination
        .Columns(5).Width = 50  'catégorie
        .Columns(6).Width = 50  'distance
        .Columns(7).Width = 60  'actif
 
 
    'On Rajoute les données
        'pour chaque cellule, on aligne le texte, on détermine la taille de police, on remplit avec les données :
 
        .Cell(1 + (1 * x), 1).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
        .Cell(1 + (1 * x), 1).Shape.TextFrame.TextRange.Font.Size = 12
        .Cell(1 + (1 * x), 1).Shape.TextFrame.TextRange.Text = Tablo(i, 2) 'désignation
        .Cell(1 + (1 * x), 2).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
        .Cell(1 + (1 * x), 2).Shape.TextFrame.TextRange.Text = Tablo(i, 3) 'calibre
        .Cell(1 + (1 * x), 2).Shape.TextFrame.TextRange.Font.Size = 12
        .Cell(1 + (1 * x), 3).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
        .Cell(1 + (1 * x), 3).Shape.TextFrame.TextRange.Text = (Tablo(i, 7) & "   " & Tablo(i, 10) & "   " & Tablo(i, 12) & "   " & Tablo(i, 14) & "   " & Tablo(i, 16)) 'Agrément1 Col F
        .Cell(1 + (1 * x), 3).Shape.TextFrame.TextRange.Font.Size = 12
        .Cell(1 + (1 * x), 4).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
        .Cell(1 + (1 * x), 4).Shape.TextFrame.TextRange.Text = Tablo(i, 9) 'dénomination
        .Cell(1 + (1 * x), 4).Shape.TextFrame.TextRange.Font.Size = 12
        .Cell(1 + (1 * x), 5).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
        .Cell(1 + (1 * x), 5).Shape.TextFrame.TextRange.Text = Tablo(i, 4) 'catégorie
        .Cell(1 + (1 * x), 5).Shape.TextFrame.TextRange.Font.Size = 12
        .Cell(1 + (1 * x), 6).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
        .Cell(1 + (1 * x), 6).Shape.TextFrame.TextRange.Text = (Tablo(i, 11) & "       " & Tablo(i, 13) & "       " & Tablo(i, 15) & "       " & Tablo(i, 17)) 'distance1 Col K=11
        .Cell(1 + (1 * x), 6).Shape.TextFrame.TextRange.Font.Size = 12
        .Cell(1 + (1 * x), 7).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
        .Cell(1 + (1 * x), 7).Shape.TextFrame.TextRange.Text = Format(Tablo(i, 5), "# ##0.000") 'actif
        .Cell(1 + (1 * x), 7).Shape.TextFrame.TextRange.Font.Size = 12
 
        End With
        End If
 
                    i = i + 1
                    x = x + 1
                    If i > UBound(Tablo) Then Exit Do
                Loop While Tablo(i, 1) <> ""
 
    End With
End If
Next
 
 
 
Next
objPres.Save
'objPres.Close
End Sub

tu as trop voulu coller au code que je t'ai fait pour l'autre tableau et tu as fini par revenir a la structure de code que tu avais présenté la 1ere fois, Si j'ai le courage je regarderais dans la soirée.

autre chose, qui est plus de l'ordre de l'organisation, prend soin de l'indentation de ton code, ton code ne respect pas les niveau et du coup ca devient vite illisible. Les gens quand ils débutent ne font jamais attention a cela et pourtant... c'est la clef de la compréhension de ce que tu fais.
Si tu n'indente pas ton code, quand tu relis, je te met au defis de savoir si tu es a l’intérieur ou a l’extérieur d'un If/End If, ou d'un With/End With.

Essai de respecter ca, itilise a bon escient la touche Tab

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
With Range("A1")
   If .Value = "Oui" then 'une tabulation
      '[...] ici ton code '2Tabulations
      If Range("E8") = "Voila" Then '2Tab
         '[...] Ton code '3Tab
      Else '2Tab même niveau que le If associé
         '[...] Ton code '3Tab
      End If ' 2Tab On referme le If qui est au même niveau (If Range("E8") = "Voila" Then)
   End If '1Tab, tu vois de suite a quel If tu fais reference
End With

++
Qwaz

**fidecourt** · 01/02/2011, 20h59

merci Qwazerty pour tes conseils,
je vais essayer d'être plus structurée dans le code,
j'avoue que je fais cela à l'arrache et que le manque de connaissances basiques me fait perdre les pédales

ton aide m'est plus que précieuse en la matière

A+

**Qwazerty** · 01/02/2011, 21h45

Salut
je te dois des excuses, après avoir retravaillé ton code, je me suis aperçu que tu avais eu de bonnes idées, tu n'as tout simplement pas su les mettre en oeuvre.

J'ai supprimé la colonne A de ton tableau excel, je pense que tu n'y verras pas d’inconvénient

.

Plus je manipule les fichiers PPT et plus je me rend compte que l'utilisation du Pot offre une grande flexibilité et limite énormément le code (dans le bon sens du terme). Il est donc préférable de placer le tableau sur un des MasterSlide, ça te permet de pouvoir le mettre en forme comme tu le souhaites.

Dans ton cas le tableau étant transparent je ne me suis pas embête, mais on pourrait tout simplement supprimer les lignes excédentaires du tableau si tel n'avait pas été le cas.

Je rajouterais le code a ce message quand il sera fini

++
Qwaz

**fidecourt** · 01/02/2011, 21h54

bon j'ai pas tout suivi mais vais surement mieux comprendre avec le code
pour les excuses, je t'en prie, tes remarques m'apprennent beaucoup et pour le coup je reste très humble en la matière !

A+

**Qwazerty** · 01/02/2011, 23h21

Salut
Me revoila... j'ai un peu galéré, j'ai un peu surestimé les Pot...
voila le fichier excel modifié ainsi que le Pot associé. www.megaupload.com/?d=ZJNUD0Y2

Dans le Pot, en mode masque tu pourras placer le tableau comme tu le souhaites (espace réservé tableau) dans le Slide2.

Par contre a mon avis la prise en compte du nombre de ligne... ça va pas le faire, tes données sont super longue et les retour a la ligne génère des lignes très hautes, ce qui fausse la hauteur total du tableau.

Je vais aller me coucher, donc essai demain de modifier le code pour tenir compte, non pas du nombre de ligne pour demander un autre slide, mais de la hauteur total de ton tableau. Si le tableau est plus grand que... hop nouveau slide.
Je sent déjà une grosse difficulté à gérer avec se type de fonctionnement. On verra.

Bonne nuit
++
Qwaz

**fidecourt** · 02/02/2011, 16h18

et bien voilà le point sur ta macro
tout fonctionne, j'ai bien les sauts de pages
mais dans ce cas Liste des Agréments, je ne veux pas de saut de page après changement de famille (B)
j'ai fait 36 essais, et suis complètement perdue avec le "AskNewSlide" et "SameTableau"
j'ai essayé de supprimer la notion SameTableau, mais automatiquement cela me génère 1 slide par ligne "famille"
j'avoue être perdue et ne plus savoir où faire le simple test du nbre de lignes >11 sans appeler le test sur la famille ???

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
For i = 2 To UBound(Tablo) 'On commence a 2 pour sauter les entetes de colonnes
 
    'On regarde si une nouvelle feuille doit etre créée :
 
'OU SUPPRIMER LE TEST DE SAUT DE PAGE SUR LA FAMILLE (en B(2) chez moi et en A(1) chez toi)
 
    'Je comprend pourquoi tu avais mis cette ligne maintenant,
    'mais tu ne pointais pas la bonne colonne aux vus de ton tableau excel (colonne B)
    SameTableau = CBool(Tablo(i, 2) = "")
    If Not SameTableau Or AskNewSlide Then
 
        'If SameTableau Then 'sous entend que l'on est rentré dans le if parce que AskNewSlide est a True
            'NomTableau = "liste des agréments"
        'Else
           ' NomTableau = "liste des agréments"
        'End If
        AskNewSlide = False
        'On ajoute un nouveau Slide 'Layout avec un tableau de 10x7 Cellule + un ligne d'entete au début (contenu dans le pot)
        Set objSld = objPres.Slides.AddSlide(objPres.Slides.Count + 1, objPres.SlideMaster.CustomLayouts(6))
 
        'On renseigne le titre du slide
        objSld.Shapes.Title.TextFrame.TextRange.Text = "liste des agréments"

je dois faire une grosse erreur d'interprétation mais je ne vois pas où ?
peux-tu m'éclairer ?
A+

**Qwazerty** · 02/02/2011, 18h06

Salut
Voila les modifs à effectuer avec les commentaires ajoutés précédés d'un '=====

Mais bon je pense que certaines choses vont te manquer, l'identification du Nom Tableau qui contient tes articles. et toujours un problème de hauteur de ligne qui font que le tableau dépasse la hauteur du Slide.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
Option Explicit
Sub PPTlisteAgrSautPage()
'source : forum Developpez.com Auteur : Qwazerty
'insertion du code Devis qui fonctionne avec sauts de pages et test adaptation
'==============================================================================
Dim objPPT As PowerPoint.Application
Dim objPres As PowerPoint.Presentation
Dim objSld As PowerPoint.Slide
Dim objShp As PowerPoint.Shape
Dim ObjShTable As PowerPoint.Shape
Dim Tablo As Variant
Dim x As Integer, i As Integer, y As Integer
Dim NomTableau As String
Dim NLigne As Byte
Dim AskNewSlide As Boolean, SameTableau As Boolean
Const cstNbrMaxLigne As Byte = 11
Dim Entete
'Dim NbrLigneAdded As Byte
'Dim sTitre As String
 
'On va utiliser Used range, c'est pratique etant donné que la colonne a ne contient pas des valeurs jusqu'en bas
'L'inconvenient c'est que les entetes sont prises aussi
Tablo = Sheets("AgrementsListeTriee").UsedRange.Value '.Range("A2:Z" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
'Attention avec UsedRange, parfois excel déconne un peu et prend en compte des lignes que tu as modifié un jour ... mais qui sont vide depuis
'Indique moi une colonne qui n'aura jamsi de cellules vide pour faire une selection plus propre
'(si tu es embeté pour faire des essais active la ligne suivante)
'Tablo = Sheets("AgrementsListeTriee").Range("A2:Z25").Value
 
'Ouvre PP
Set objPPT = CreateObject("Powerpoint.Application")
objPPT.Visible = True
 
'Ajoute une présentation
Set objPres = objPPT.Presentations.Add
objPres.SaveAs ThisWorkbook.Path & "\Agrements.pptx"
 
'On charge le modele
objPres.ApplyTemplate ThisWorkbook.Path & "\ModeleMon.pot"
 
'Je te laisse ajouter du code pour créer ta feuille de présentation
 
'On prepare les enetet
Entete = Array("Designation", "Calibre", "Agrement", "Dénomination", "Catégorie", "Distance", "Actif")
 
'=====
'Pour le 1er tour on initialise AskNewSlide a true, on demande donc un nouveau Slide (le 1er)
AskNewSlide = True
 
For i = 2 To UBound(Tablo) 'On commence a 2 pour sauter les entetes de colonnes
 
    'On regarde si une nouvelle feuille doit etre créée
    'Je comprend pourquoi tu avais mis cette ligne maintenant,
    'mais tu ne pointais pas la bonne colonne aux vus de ton tableau excel (colonne B)
'=====
    'ici on regarde si le nomde tableau est vide
    'S'il est vide => on a toujours le même tableau
    'S'il n'est pas vide, on a un tableau different
    'Donc cette ligne on la vire et on supprime les reference a SameTableau
    'SameTableau = CBool(Tablo(i, 1) = "")
    'Par contre je comprend pas trop dans ton tableau comment tu vas distinguer les ligne appartenant a tel ou tel tableau
    'Peut etre que c'est simplement inutile de le faire?
    If AskNewSlide Then 'Not SameTableau Or
'====
        'If SameTableau Then 'sous entend que l'on est rentré dans le if parce que AskNewSlide est a True
        '    NomTableau = NomTableau & " (Suite...)"
        'Else
        '    NomTableau = Tablo(i, 1)
        'End If
        AskNewSlide = False
        'On ajoute un nouveau Slide 'Layout avec un tableau de 10x7 Cellule + un ligne d'entete au début (contenu dans le pot)
        Set objSld = objPres.Slides.AddSlide(objPres.Slides.Count + 1, objPres.SlideMaster.CustomLayouts(2))
 
        'On renseigne le titre du slide
        objSld.Shapes.Title.TextFrame.TextRange.Text = "liste des agréments"
        'Tu definiras directement la police dans ton .Pot, vu que cette fois le tableau s'y trouve déjà d'implanté
        'objSld.Shapes.Title.TextFrame.TextRange.Font.Name = "brush script std" '
        'objSld.Shapes.Title.TextFrame.TextRange.Font.Size = 20
 
        'On place le tableau dans l'espace reservé
        Set ObjShTable = objSld.Shapes.AddTable(cstNbrMaxLigne, 7)
 
        'On dimenssionne les colonnes
        With ObjShTable.Table
            .Columns(1).Width = 130 'designation
            .Columns(2).Width = 50  'calibre
            .Columns(3).Width = 100 'agrement
            .Columns(4).Width = 200 'dénomination
            .Columns(5).Width = 50  'catégorie
            .Columns(6).Width = 50  'distance
            .Columns(7).Width = 60  'actif
 
            'On formate le tableau avec un style vierge
 '           .ApplyStyle "{2D5ABB26-0587-4C30-8999-92F81FD0307C}", True
 
            'Les entete de colonne
            For x = 1 To 7
                .Cell(1, x).Shape.TextFrame.TextRange.Text = Entete(x - 1)
                'Si tu veux modifier la font des entetes tu le feras ici,
                'les alignements devront se faire soit un par un (si differents les uns des autres)
                'soit dans un tableau comme pour les textes des entetes
            Next
 
        End With
 
        NLigne = 2 'On commencera donc directement a écrire sur la ligne 2
    End If
 
 
    'On Rajoute les données
    'pour chaque cellule, on aligne le texte, on détermine la taille de police, on remplit avec les données :
    With ObjShTable.Table
        With .Cell(NLigne, 1).Shape.TextFrame.TextRange
            .ParagraphFormat.Alignment = ppAlignLeft
            .Font.Size = 12
            .Text = Tablo(i, 2) 'désignation
        End With
        With .Cell(NLigne, 2).Shape.TextFrame.TextRange
            .ParagraphFormat.Alignment = ppAlignRight
            .Text = Tablo(i, 3) 'calibre
            .Font.Size = 12
        End With
        With .Cell(NLigne, 3).Shape.TextFrame.TextRange
            .ParagraphFormat.Alignment = ppAlignLeft
            .Text = (Tablo(i, 7) & "   " & Tablo(i, 10) & "   " & Tablo(i, 12) & "   " & Tablo(i, 14) & "   " & Tablo(i, 16)) 'Agrément1 Col F
            .Font.Size = 12
        End With
        With .Cell(NLigne, 4).Shape.TextFrame.TextRange
            .ParagraphFormat.Alignment = ppAlignLeft
            .Text = Tablo(i, 9) 'dénomination
            .Font.Size = 12
        End With
        With .Cell(NLigne, 5).Shape.TextFrame.TextRange
            .ParagraphFormat.Alignment = ppAlignCenter
            .Text = Tablo(i, 4) 'catégorie
            .Font.Size = 12
        End With
        With .Cell(NLigne, 6).Shape.TextFrame.TextRange
            .ParagraphFormat.Alignment = ppAlignRight
            .Text = (Tablo(i, 11) & "       " & Tablo(i, 13) & "       " & Tablo(i, 15) & "       " & Tablo(i, 17)) 'distance1 Col K=11
            .Font.Size = 12
        End With
        With .Cell(NLigne, 7).Shape.TextFrame.TextRange
            .ParagraphFormat.Alignment = ppAlignRight
            .Text = Format(Tablo(i, 5), "# ##0.000") 'actif
            .Font.Size = 12
        End With
 
    End With
 
    NLigne = NLigne + 1 'On passe a la ligne suivante de notre tableau sur le Slide
'====
    'C'est ici que l'on regarde si une nouvelle diopa est necessaire
    If NLigne > cstNbrMaxLigne Then AskNewSlide = True 'entete + 10 lignes
 
Next
 
 
 
objPres.Save
'objPres.Close
End Sub

++
Qwaz

**fidecourt** · 02/02/2011, 19h09

bonsoir et merci Qwazerty,

c'est bon de cette façon
dans ce fichier inutile de changer de page par famille de produits, sinon il risquerait d'y avoir trop de pages générées
donc il faut juste une liste de tous les agréments des produits du devis
Désignation (correspond à la famille de produit, est mise uniquement si différente de celle du dessus, d'où ma col A avec sur chaque ligne la famille, et la col B avec uniquement le nom de la famille quand différente de celle du dessus)
cela évite de répéter à chaque ligne :
Famille UN /Agrément/Dénomination,
Famille UN /Agrément/Dénomination
Famille UN /Agrément/Dénomination etc...

mais

Famille UN /Agrément/Dénomination
/Agrément/Dénomination
/Agrément/Dénomination

Famille DEUX/Agrément/Dénomination
/Agrément/Dénomination
/Agrément/Dénomination

mais il faut juste une liste complète

je vais remettre la dispo en ordre pour ne pas avoir de souci avec la présentation, car comme plusieurs agréments et distances de sécu pour un même article, je dois tenir compte de la hauteur de la cellule
bref pas simple tout de même

je te tiens informé pour la suite
encore mille mercis pour ton aide précieuse !

Excel-->PPT saut page et titre colonnes [XL-2010]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager