Eric KERGRESSE

Ce billet est en lien avec ce message : possible-d-obtenir-index-automatique-ordre-l-alphabet

Le code, ci-dessous, liste les entrées de la table 1 des index d'un document Word, les trie dans l'ordre souhaité et les restitue dans un tableau en fin de document. Il ne supprime pas la table des index dont il s'est servi.

La liste d'index est une chaîne string dans laquelle les entrées sont séparées par des retours chariot. En splitant la liste d'index avec un Chr(13), les items renvoyés peuvent contenir des caractères parasites en début de chaîne. La fonction PremiereLettreChaine permet de trouver le premier caractère dans la liste Chr(65) à Chr(90) autrement dit de A à Z. C'est ce caractère qui va permettre d'alimenter une matrice des index et son édition dans un tableau par la suite.

Code vba :

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
 
Option Explicit
 
Sub TesterListerLesIndexParOrdreUtilisateur()
 
Dim DocEnCours As Document
Dim OrdreIndex As Variant
 
    Set DocEnCours = ActiveDocument
 
    OrdreIndex = Array("G", "E", "D", "P", "C", "I", "O") ' La liste doit être en majuscules
 
    ListerLesIndexParOrdreUtilisateur DocEnCours, OrdreIndex
 
    Set DocEnCours = Nothing
 
 
End Sub
 
Sub ListerLesIndexParOrdreUtilisateur(ByVal DocEnCours2 As Document, ByVal OrdreIndex2 As Variant)
 
Dim I As Integer, J As Integer, K As Integer, IndexTableau As Integer, IndiceIndex As Integer
Dim MonTexte As String, TexteCellule1 As String, TexteCellule2 As String
Dim MonContenu As Variant
Dim TableauDIndex() As Variant
Dim MonRange As Range
Dim Continuer As Boolean
Dim TableIndex As Table
 
    Erase TableauDIndex
 
    With DocEnCours2
 
         If .Indexes.Count = 0 Then Exit Sub
 
         If .Tables.Count > 0 Then
            For I = .Tables.Count To 1 Step -1
                If InStr(1, .Tables(I).Cell(1, 1).Range.Text, "Table des index", vbTextCompare) > 0 Then .Tables(I).Delete
            Next I
         End If
 
        .Indexes(1).Update
         MonContenu = Split(.Indexes(1).Range.Text, Chr(13))
 
         IndiceIndex = 0
         If UBound(MonContenu) > 0 Then
            For I = LBound(OrdreIndex2) To UBound(OrdreIndex2)
                For J = LBound(MonContenu, 1) To UBound(MonContenu, 1)
                    If PremiereLettreChaine(MonContenu(J)) = OrdreIndex2(I) Then
                       ReDim Preserve TableauDIndex(IndiceIndex)
                       TableauDIndex(IndiceIndex) = MonContenu(J)
                       IndiceIndex = IndiceIndex + 1
                    End If
            Next J
                Next I
        End If
 
        Selection.EndKey unit:=wdStory
        Selection.MoveEnd unit:=wdParagraph, Count:=1
 
 
        Set TableIndex = .Tables.Add(Range:=Selection.Range, NumRows:=UBound(TableauDIndex) + 2, NumColumns:= _
        2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed)
 
        With TableIndex
              IndexTableau = 1
              With .Cell(IndexTableau, 1).Range
                    .Text = "Table des index"
                  '  .Style = "Titre 1"
                  '  .Paragraphs.SpaceBefore = False
              End With
              With .Cell(IndexTableau, 2).Range
                    .Text = "Renvois"
                  '  .Style = "Titre 1"
                  '  .Paragraphs.SpaceBefore = False
              End With
              IndexTableau = 2
        End With
 
        For I = LBound(TableauDIndex) To UBound(TableauDIndex)
            MonTexte = ""
            TexteCellule1 = ""
            TexteCellule2 = ""
            Continuer = True
            For K = 1 To Len(TableauDIndex(I))
                For J = 0 To 255
                     If Mid(TableauDIndex(I), K, 1) = Chr(J) Then
                        Select Case J
                               Case 0 To 8
 
                               Case 9
                                    Continuer = False ' On passe dans la deuxième colonne après la tabulation
 
                               Case 10 To 31
 
 
                               Case Else
                                    MonTexte = MonTexte & Mid(TableauDIndex(I), K, 1)
                                    If Continuer = True Then TexteCellule1 = TexteCellule1 & Mid(TableauDIndex(I), K, 1)
                                    If Continuer = False Then TexteCellule2 = TexteCellule2 & Mid(TableauDIndex(I), K, 1)
                         End Select
 
                          Debug.Print J & ", "
                     End If
                 Next J
             Next K
 
             Debug.Print TableauDIndex(I)
 
             Selection.EndKey unit:=wdStory
 
             With TableIndex
                    .Cell(IndexTableau, 1).Range.Text = TexteCellule1
                    .Cell(IndexTableau, 2).Range.Text = TexteCellule2
                    IndexTableau = IndexTableau + 1
             End With
 
          '   Selection.Range.Text = MonTexte & Chr(10) 'TableauDIndex(0, I) & Chr(10)
 
        Next I
 
    End With
 
    Set TableIndex = Nothing
 
 
End Sub
 
Function PremiereLettreChaine(ByVal ChaineATraiter) As String
 
Dim CtrI As Integer, CtrJ As Integer
 
         PremiereLettreChaine = ""
         For CtrI = 1 To Len(ChaineATraiter)
 
             For CtrJ = 65 To 90
                 If UCase(Mid(ChaineATraiter, CtrI, 1)) = Chr(CtrJ) Then
                    PremiereLettreChaine = Chr(CtrJ)
                    Exit Function
                 End If
             Next CtrJ
 
         Next CtrI
 
End Function