Ne pas incrémenter ligne d'un tableau si vide - aide

**thespeedy20** · 20/09/2020, 22h58

Bonjour à tous,

Lors d'une importation d'Excel vers Word, j'ai un tableau qui s'incrémente(pour les lignes remplies et ainsi que les lignes vides), j'aimerais que cela ne s'incrémente que quand il y a une données dans la ligne?

Nom : Tableau word.JPG
Affichages : 123
Taille : 15,2 Ko

Nom : Tableau word.JPG
Affichages : 123
Taille : 15,2 Ko

voici ce que j'ai actuellement

et ce que je désirerais :

Nom : Tableau word2.JPG
Affichages : 108
Taille : 15,2 Ko

Voici mon 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
 
Sub Transfert_Provisoire()
 
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("Résultat") 'La feuille lue dans le classeur Excel
 
    With ShEleves
 
         PremiereLigneTableau = 2
         DerniereLigneTableau = .Cells(.Rows.Count, 2).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, 3), .Cells(DerniereLigneTableau, 3))
 
         Set WordApp = CreateObject("word.application")
         WordApp.Visible = True
         Set WordDoc = WordApp.Documents.Open(ThisWorkbook.Path & "\Presences_A3_2021.docx")
 
         If WordDoc.tables.Count < 1 Then
            MsgBox "Le document Word ne contient pas de 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) & " " & CelluleEleve.Offset(0, 9)
                            ' End With
                        Case Else
                              With TableauWd2
                                  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) & " " & CelluleEleve.Offset(0, 9)
                            ' 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
    Résult = InputBox("Nom de la Sauvegarde du Fichier Word ?", "Titre")
     .SaveAs2 Filename:=ThisWorkbook.Path & "\" & Résult & ".docx", FileFormat:=wdFormatXMLDocument, LockComments:=False, _
                   Password:="", AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
                   SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False, CompatibilityMode:=14
          '.Close
 
     End With
 
    WordApp.Visible = True
    WordApp.Activate
    Set WordDoc = Nothing
    Set WordApp = Nothing
 
    'MsgBox "Fin du transfert !", vbInformation
 
End Sub

Merci d'avance pour votre aide

OLi

Invité · 21/09/2020, 04h28

Envoyé par thespeedy20

Bonjour,

Il suffirait sans doute de tester la valeur de la variable CelluleEleve et d'affecter la valeur CompteurEleve à la première cellule des tableaux.

**thespeedy20** · 21/09/2020, 19h57

Bonsoir Eric KERGRESSE,

Merci pour l'information mais je ne vois pas comment procéder...

Oli

Invité · 22/09/2020, 01h22

Envoyé par thespeedy20

Pas testé. On ne tient pas compte de la numérotation de votre tableau Excel, on prend celle du compteur, les colonnes prises en compte sont donc celles de 3 à 8.

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
 
         CompteurEleve = 0
         For Each CelluleEleve In AireEleve
             If CelluleEleve <> "" Then
                 Select Case CompteurEleve
                        Case Is < 30
                             With TableauWd1
                                  .Cell(CompteurEleve + 3, 1).Range.Text = CompteurEleve
                                  For ColonneWd = 3 To 8
                                      .Cell(CompteurEleve + 3, ColonneWd).Range.Text = CelluleEleve.Offset(0, ColonneWd - 2)
                                  Next ColonneWd
                             End With
                        Case Else
                              With TableauWd2
                                   .Cell(CompteurEleve + 3, 1).Range.Text = CompteurEleve
                                  For ColonneWd = 3 To 8
                                       .Cell(CompteurEleve + 3 - 30, ColonneWd).Range.Text = CelluleEleve.Offset(0, ColonneWd - 2)
                                   Next ColonneWd
                              End With
                 End Select
                 CompteurEleve = CompteurEleve + 1
             End If
         Next CelluleEleve

**thespeedy20** · 23/09/2020, 00h32

Bonsoir Eric KERGRESSE,

Votre code incrémente bien mais supprime l'espace vide... il faut absolument que je garde cet espace ...

Bien à vous

OLi

Invité · 23/09/2020, 04h42

Envoyé par thespeedy20

Oui effectivement. Dans ce cas, il faut différencier l'incrémentation de la variable CompteurEleve de celle CompteurLigne :

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
 
         CompteurEleve = 0
         CompteurLigne = 0
         For Each CelluleEleve In AireEleve
             If CelluleEleve <> "" Then
                 Select Case CompteurEleve
                        Case Is < 30
                             With TableauWd1
                                  .Cell(CompteurLigne + 3, 1).Range.Text = CompteurEleve
                                  For ColonneWd = 3 To 8
                                      .Cell(CompteurLigne + 3, ColonneWd).Range.Text = CelluleEleve.Offset(0, ColonneWd - 2)
                                  Next ColonneWd
                             End With
                        Case Else
                              With TableauWd2
                                   .Cell(CompteurLigne + 3, 1).Range.Text = CompteurEleve
                                  For ColonneWd = 3 To 8
                                       .Cell(CompteurLigne + 3 - 30, ColonneWd).Range.Text = CelluleEleve.Offset(0, ColonneWd - 2)
                                   Next ColonneWd
                              End With
                 End Select
                 CompteurEleve = CompteurEleve + 1
             End If
             CompteurLigne = CompteurLigne + 1
         Next CelluleEleve

**thespeedy20** · 25/09/2020, 15h54

Bonjour Eric KERGRESSE,

Votre code fonctionne à merveille, je vous remercie vivement...

Rapide - simple et efficace

OLi

**thespeedy20** · 27/09/2020, 22h02

Bonsoir Eric KERGRESSE,

Je reviens vers vous...

J'ai un petit soucis quand je dépasse les 30 lignes, il passe sur le second tableau, mais la numérotation de s'inscrit plus...(sur le premier pas de soucis)
il indique seulement la dernière numérotation une ligne après...

Nom : Tableau word3.JPG
Affichages : 86
Taille : 16,4 Ko

Nom : Tableau word3.JPG
Affichages : 86
Taille : 16,4 Ko

Pouvez-me dire pourquoi ?

Merci

OLi

Invité · 28/09/2020, 04h34

Envoyé par thespeedy20

Il faut remettre à 0 le compteur de lignes au changement de tableau.

**thespeedy20** · 28/09/2020, 13h03

Bonjour Eric KERGRESSE

J'ai remis le compteur à zero avant le deuxième tableau...

et la je vois défiler sur la premier ligne du second tableau l'incrémentation ainsi que mes données, et s'arrêtent sur le dernier enregistrement...?? toujours sur la première ligne

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
CompteurEleve = 1
         CompteurLigne = 0
         For Each CelluleEleve In AireEleve
             If CelluleEleve <> "" Then
                 Select Case CompteurEleve
                        Case Is < 25
                             With TableauWd1
                                  .Cell(CompteurLigne + 3, 1).Range.Text = CompteurEleve
                                  For ColonneWd = 2 To 7
                                      .Cell(CompteurLigne + 3, ColonneWd).Range.Text = CelluleEleve.Offset(0, ColonneWd - 2)
                                  Next ColonneWd
                             End With
                        Case Else
                              CompteurLigne = 0
                              With TableauWd2
                                  
                                   .Cell(CompteurLigne + 3, 1).Range.Text = CompteurEleve
                                  For ColonneWd = 2 To 7
                                       .Cell(CompteurLigne + 3, ColonneWd).Range.Text = CelluleEleve.Offset(0, ColonneWd - 2)
                                   Next ColonneWd
                             
                              End With
                              
                 End Select
                 CompteurEleve = CompteurEleve + 1
                 
             End If
             CompteurLigne = CompteurLigne + 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

Invité · 29/09/2020, 05h31

Envoyé par thespeedy20

A tester :

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
 
    CompteurEleve = 1
    CompteurLigne = 0
    CompteurTotal = 0
 
    For Each CelluleEleve In AireEleve
        If CelluleEleve <> "" Then
           Select Case CompteurTotal
 
                  Case Is < 30
 
                       With TableauWd1
                            .Cell(CompteurLigne + 3, 1).Range.Text = CompteurEleve
                            For ColonneWd = 2 To 7
                                .Cell(CompteurLigne + 3, ColonneWd).Range.Text = CelluleEleve.Offset(0, ColonneWd - 2)
                            Next ColonneWd
                       End With
 
                  Case Else
 
                       With TableauWd2
                            .Cell(CompteurLigne + 3, 1).Range.Text = CompteurEleve
                            For ColonneWd = 2 To 7
                                .Cell(CompteurLigne + 3, ColonneWd).Range.Text = CelluleEleve.Offset(0, ColonneWd - 2)
                            Next ColonneWd
                       End With
 
           End Select
           CompteurEleve = CompteurEleve + 1
        End If
 
        CompteurLigne = CompteurLigne + 1
        If CompteurLigne = 30 Then CompteurLigne = 0
        CompteurTotal = CompteurTotal + 1
 
    Next CelluleEleve

**thespeedy20** · 30/09/2020, 01h23

Bonsoir Eric KERGRESSE,

C'est parfait, cela fonctionne très bien...
Je vous remercie encore pour le temps consacré à mon problème...

Je vous souhaite une excellente soirée...

OLi

Ne pas incrémenter ligne d'un tableau si vide - aide [WD-2019]

Word

Discussions similaires

Partager

Partager