Sub AnaTitre1()
Dim WORDApp As Word.Application
Dim WordDoc As Word.Document
Dim Titl(), Tb(), i As Long, N°Page As Integer, N°Tb As Integer
Dim Para As Paragraph, Tabl As Table
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
On Error Resume Next
'A adapter
Set WORDApp = GetObject(, "Word.Application")
Set WordDoc = WORDApp.Documents("Doc Essai.docx")
On Error GoTo 0
If WordDoc Is Nothing Then Exit Sub
i = 0
For Each Para In WordDoc.Paragraphs
If Para.Style = "Titre 1" Then
N°Page = Para.Range.Information(wdActiveEndAdjustedPageNumber)
i = i + 1: ReDim Preserve Titl(1 To 2, 1 To i): Titl(2, i) = N°Page: Titl(1, i) = Para.Range.Text
Dic(N°Page) = Dic(N°Page) + 1
End If
Next
i = 0
N°Tb = 0
For Each Tabl In WordDoc.Tables
N°Tb = N°Tb + 1
N°Page = Tabl.Range.Information(wdActiveEndAdjustedPageNumber)
If Dic.Exists(N°Page) Then
i = i + 1
ReDim Preserve Tb(1 To 2, 1 To i)
Tb(1, i) = N°Tb: Tb(2, i) = N°Page
End If
Next
'Ecrire la liste des Titre1 et leur page
Feuil1.[A2].Resize(UBound(Titl, 2), 2).Value = WorksheetFunction.Transpose(Titl)
'Ecrire les N° de tableau et leur page
Feuil1.[D2].Resize(UBound(Tb, 2), 2).Value = WorksheetFunction.Transpose(Tb)
Set WordDoc = Nothing
Set WORDApp = Nothing
End Sub