Discussion :

[thespeedy20]

Bonjour aux membre de ce forum

Je requiers votre aide, voici mon problème, j'importe des données d'excel dans un tableau word (1er et 2éme page), est il possible de reproduire le tableau des page 1 et 2 si les données dépasses 30 qui est la capacité des tableaux(si non erreur de la macro excel...)

Merci d'avance pour votre aide ou vos solutions

olivier

[Invité]

Bonjour,

Votre fichier .doc étant en fait un modèle, une solution consisterait à déjà prévoir le cas du dépassement des 30 élèves. Dans votre macro excel, vous basculez sur les Tables(3) et Tables(4) à partir du 31ème élève, sinon vous supprimez les tables 4 et 3 (dans cet ordre) à la fin du programme.

Cordialement.

[thespeedy20]

Bonsoir,

Pourriez-vous me montrer comment basculer vers le tableau 3 et 4

Merci d'avance

Olivier

[Invité]

Pourriez-vous me montrer comment basculer vers le tableau 3 et 4

?

De la même manière que vous avez fait pour les tableaux 1 et 2 . Par exemple, ici pour les tableaux 1 et 2 :

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
 
        Set Tablo = WordDoc.Tables(1)
        For NoLig = debut To fin
             With Tablo
                    For col = 1 To 7
                          .Columns(col + 1).Cells((NoLig + 1)).Range.Text = FL1.Cells(NoLig, col)
                    Next
             End With
       Next NoLig
 
       Set Tablo = WordDoc.Tables(2)
            For NoLig = debut To fin
                 With Tablo
                        For col = 1 To 2
                             .Columns(col + 1).Cells((NoLig + 1)).Range.Text = FL1.Cells(NoLig, col + 7)
                        Next
                 End With
          Next NoLig

Dans ce code, il suffit de :

- Tester le nombre d'enregistrements du tableau Excel avec un If Else End If.
- Remplacer "fin" par 30 pour les tableaux 1 et 2.
- De dupliquer le code pour les tableaux 1 et 2.
- De redémarrer sur les tableaux 3 et 4, en remplaçant debut par 31.

Cordialement.

[thespeedy20]

Bonjour Eric,

Voilà mon fichier, mais cela ne fonctionne pas, peux-tu me dire ou se trouve l'erreur.

Merci d'avance

Olivier

[Invité]

Voilà mon fichier, mais cela ne fonctionne pas, peux-tu me dire ou se trouve l'erreur.

Bonsoir,

A essayer :

Penser à ajouter la référence Microsoft Word.

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
 
Option Explicit
 
 
Sub TransfertModifieEK()
 
Dim WordApp As Object
Dim WordDoc As Object
 
Dim TableauWd1 As Word.Table
Dim TableauWd2 As Word.Table
Dim TableauWd3 As Word.Table
Dim TableauWd4 As Word.Table
 
Dim NbTablesWd As Integer
Dim ColonneWd As Integer
 
Dim CompteurEleve As Long
Dim PremiereLigneTableau As Long
Dim DerniereLigneTableau As Long
 
Dim ShEleves As Worksheet
Dim AireEleve As Range
Dim CelluleEleve As Range
 
 
    Set ShEleves = Worksheets("Feuil1") 'La feuille lue dans le classeur Excel
 
    With ShEleves
 
         PremiereLigneTableau = 2
         DerniereLigneTableau = .Cells(.Rows.Count, 1).End(xlUp).Row
         If DerniereLigneTableau < PremiereLigneTableau Then
            MsgBox "Aucun élève dans le tableau, fin de programme !", vbCritical
            Exit Sub
         End If
 
         Set AireEleve = .Range(.Cells(PremiereLigneTableau, 1), .Cells(DerniereLigneTableau, 1))
 
         Set WordApp = CreateObject("word.application")
         WordApp.Visible = True
         Set WordDoc = WordApp.Documents.Open(ThisWorkbook.Path & "\test_4.docx")
 
         If WordDoc.tables.Count < 4 Then
            MsgBox "Le document Word ne contient pas les 4 tableaux, fin de programme !", vbCritical
         Else
            With WordDoc
                   Set TableauWd1 = .tables(1)
                   Set TableauWd2 = .tables(2)
                   Set TableauWd3 = .tables(3)
                   Set TableauWd4 = .tables(4)
            End With
         End If
 
         CompteurEleve = 0
 
         For Each CelluleEleve In AireEleve
             If CelluleEleve <> "" Then
                 Select Case CompteurEleve
                        Case Is < 30
                             With TableauWd1
                                  For ColonneWd = 2 To 8
                                      .Cell(CompteurEleve + 3, ColonneWd).Range.Text = CelluleEleve.Offset(0, ColonneWd - 2)
                                  Next ColonneWd
                             End With
                             With TableauWd2
                                  .Cell(CompteurEleve + 3, 2).Range.Text = CelluleEleve.Offset(0, 7) & " " & CelluleEleve.Offset(0, 8)
                             End With
 
                        Case Else
 
                              With TableauWd3
                                  For ColonneWd = 2 To 8
                                      .Cell(CompteurEleve + 3 - 30, ColonneWd).Range.Text = CelluleEleve.Offset(0, ColonneWd - 2)
                                  Next ColonneWd
                             End With
                             With TableauWd4
                                  .Cell(CompteurEleve + 3 - 30, 2).Range.Text = CelluleEleve.Offset(0, 7) & " " & CelluleEleve.Offset(0, 8)
                             End With
                 End Select
                 CompteurEleve = CompteurEleve + 1
             End If
         Next CelluleEleve
 
         If CompteurEleve < 31 Then
            TableauWd4.Delete
            TableauWd3.Delete
         End If
 
     End With
 
     Set TableauWd1 = Nothing
     Set TableauWd2 = Nothing
     Set TableauWd3 = Nothing
     Set TableauWd4 = Nothing
 
     Set AireEleve = Nothing
     Set ShEleves = Nothing
 
 
    'WordApp.PrintOut
     With WordDoc
 
         .SaveAs2 Filename:=ThisWorkbook.Path & "\Registre_de.docx", FileFormat:= _
           wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
           :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
           :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
           SaveAsAOCELetter:=False, CompatibilityMode:=14
          .Close
 
     End With
 
    Set WordDoc = Nothing
    WordApp.Quit ' pas oublier !
    Set WordApp = Nothing
 
    MsgBox "Fin du transfert !", vbInformation
 
 
End Sub

Cordialement.

[thespeedy20]

Bonsoir Eric,

Grand merci pour ton aide , les premiers tests sont concluant....

Il y a juste une chose , dans la base de données, j'ai des lignes vides et dans le transfert il n'y a plus.
Est il possible de les remettre ?(les lignes vides)

encore merci pour ton aide et tes conseils

Amicalement

Olivier

[thespeedy20]

Re, Eric

Quand les données sont inférieur à 30, il efface bien les deux tableaux mais reste une page blanche !
Une petite solution

Encore grand merci.

Olivier

[Invité]

Bonjour,

Il y a juste une chose , dans la base de données, j'ai des lignes vides et dans le transfert il n'y a plus.
Est il possible de les remettre ?(les lignes vides)

Il faut simplement supprimer les lignes 'If CelluleEleve <> ""' et 'End If' .

Quand les données sont inférieur à 30, il efface bien les deux tableaux mais reste une page blanche !

Il te faut créer un signet nommé Pages3Et4 qui ira de la ligne suivant le tableau 2, englobant les tableaux 3 et 4 jusqu'à la fin du document.

Ci-joint, le nouveau 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
 
Option Explicit
 
Sub TransfertModifieEK2()
 
Dim WordApp As Object
Dim WordDoc As Object
 
Dim TableauWd1 As Word.Table
Dim TableauWd2 As Word.Table
Dim TableauWd3 As Word.Table
Dim TableauWd4 As Word.Table
 
Dim NbTablesWd As Integer
Dim ColonneWd As Integer
 
Dim CompteurEleve As Long
Dim PremiereLigneTableau As Long
Dim DerniereLigneTableau As Long
 
Dim ShEleves As Worksheet
Dim AireEleve As Range
Dim CelluleEleve As Range
 
Dim SignetEnCours  As Bookmark
 
    Set ShEleves = Worksheets("Feuil1") 'La feuille lue dans le classeur Excel
 
    With ShEleves
 
         PremiereLigneTableau = 2
         DerniereLigneTableau = .Cells(.Rows.Count, 1).End(xlUp).Row
         If DerniereLigneTableau < PremiereLigneTableau Then
            MsgBox "Aucun élève dans le tableau, fin de programme !", vbCritical
            Exit Sub
         End If
 
         Set AireEleve = .Range(.Cells(PremiereLigneTableau, 1), .Cells(DerniereLigneTableau, 1))
 
         Set WordApp = CreateObject("word.application")
         WordApp.Visible = True
         Set WordDoc = WordApp.Documents.Open(ThisWorkbook.Path & "\test_4.docx")
 
         If WordDoc.tables.Count < 4 Then
            MsgBox "Le document Word ne contient pas les 4 tableaux, fin de programme !", vbCritical
         Else
            With WordDoc
                   Set TableauWd1 = .tables(1)
                   Set TableauWd2 = .tables(2)
                   Set TableauWd3 = .tables(3)
                   Set TableauWd4 = .tables(4)
            End With
         End If
 
         CompteurEleve = 0
         For Each CelluleEleve In AireEleve
                 Select Case CompteurEleve
                        Case Is < 30
                             With TableauWd1
                                  For ColonneWd = 2 To 8
                                      .Cell(CompteurEleve + 3, ColonneWd).Range.Text = CelluleEleve.Offset(0, ColonneWd - 2)
                                  Next ColonneWd
                             End With
                             With TableauWd2
                                  .Cell(CompteurEleve + 3, 2).Range.Text = CelluleEleve.Offset(0, 7) & " " & CelluleEleve.Offset(0, 8)
                             End With
                        Case Else
                              With TableauWd3
                                  For ColonneWd = 2 To 8
                                      .Cell(CompteurEleve + 3 - 30, ColonneWd).Range.Text = CelluleEleve.Offset(0, ColonneWd - 2)
                                  Next ColonneWd
                             End With
                             With TableauWd4
                                  .Cell(CompteurEleve + 3 - 30, 2).Range.Text = CelluleEleve.Offset(0, 7) & " " & CelluleEleve.Offset(0, 8)
                             End With
                 End Select
                 CompteurEleve = CompteurEleve + 1
         Next CelluleEleve
 
         ' Suppression des pages 3 et 4. Le signet Pages3Et4 va de la ligne suivant le tableau 2 jusqu'à la fin du document.
         If CompteurEleve < 31 Then
            For Each SignetEnCours In WordDoc.Bookmarks
                With SignetEnCours
                     If .Name = "Pages3Et4" Then .Range.Delete
                End With
            Next SignetEnCours
         End If
 
     End With
 
     Set TableauWd1 = Nothing
     Set TableauWd2 = Nothing
     Set TableauWd3 = Nothing
     Set TableauWd4 = Nothing
 
     Set AireEleve = Nothing
     Set ShEleves = Nothing
 
     With WordDoc
          .SaveAs2 Filename:=ThisWorkbook.Path & "\Registre_de.docx", FileFormat:=wdFormatXMLDocument, LockComments:=False, _
                   Password:="", AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
                   SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False, CompatibilityMode:=14
          .Close
     End With
 
    Set WordDoc = Nothing
    WordApp.Quit ' pas oublier !
    Set WordApp = Nothing
 
    MsgBox "Fin du transfert !", vbInformation
 
End Sub

Cordialement.

[thespeedy20]

Bonjour Eric,

cela fonction impeccablement bien....
Je te remercie pour l'aide dans ce projet

je clôture ici ce poste

Encore merci

Olivier