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
| Sub Recuperation()
Dim WordAppli As Word.Application
'Dim ExcelAppli As Excel.Application
Dim WordDoc As Word.Document
Dim oChemin As String, oChapitre As String
Dim oWksh As Worksheet
Dim oLast As Integer, n As Integer, i As Integer, j As Integer
Dim oRng_table As Range
Dim oTable_matiere() As String, oDecomp() As String, oNewRech As String
With ThisWorkbook
'Changer le titre par le titre exact de la nouvelle page excel
With .Worksheets("Util")
oChemin = .Range("B1")
oChapitre = .Range("B2")
End With
Set oWksh = Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
End With
On Error Resume Next
Set WordAppli = GetObject(, "Word.Application")
Set WordDoc = WordAppli.Documents(oChemin)
If WordDoc Is Nothing Then
Set WordAppli = CreateObject("Word.Application")
WordAppli.Documents.Open Filename:=oChemin
Set WordDoc = WordAppli.Documents(oChemin)
End If
WordAppli.Visible = True
With WordDoc
.TablesOfContents(1).Range.Copy
End With
With oWksh
.PasteSpecial Format:="Texte", Link:=False, DisplayAsIcon:=False
Set oRng_table = .Columns(1).Find(oChapitre, LookIn:=xlValues, LookAt:=xlWhole)
If Not oRng_table Is Nothing Then
n = 1
Do While Left(oRng_table.Offset(n - 1, 0), 1) = oChapitre
ReDim Preserve oTable_matiere(1 To 2, 1 To n)
If Right(oRng_table.Offset(n - 1, 0), 1) = "." Then
oTable_matiere(1, n) = oRng_table.Offset(n - 1, 0)
Else
oTable_matiere(1, n) = oRng_table.Offset(n - 1, 0) & "."
End If
oTable_matiere(2, n) = oRng_table.Offset(n - 1, 1)
n = n + 1
Loop
Else
MsgBox "Le chapitre souhaité n'est pas présent dans le document."
Exit Sub
End If
End With
With ThisWorkbook.Worksheets("DPGF")
'Changer le titre par le titre exact de la nouvelle page excel
For i = LBound(oTable_matiere, 2) To UBound(oTable_matiere, 2)
Set oRng_table = .Columns(1).Find(oTable_matiere(1, i), LookIn:=xlValues, LookAt:=xlWhole)
If oRng_table Is Nothing Then
oDecomp() = Split(oTable_matiere(1, i), ".")
n = 1
Do While True
oNewRech = ""
For j = LBound(oDecomp) To UBound(oDecomp) - n
oNewRech = oNewRech & oDecomp(j) & "."
Next j
Set oRng_table = .Columns(1).Find(oNewRech, LookIn:=xlValues, LookAt:=xlWhole)
If oRng_table Is Nothing Then
If Compte_point(oNewRech) > 2 Then
n = n + 1
Else
Call Creation_chapitre(oTable_matiere(1, i), oTable_matiere(2, i))
Exit Do
End If
Else
Call Creation_intitule(oTable_matiere(1, i), oTable_matiere(2, i), oRng_table)
Exit Do
End If
Loop
End If
Next i
Application.DisplayAlerts = False
oWksh.Delete
Application.DisplayAlerts = True
.Select
End With
End Sub
Sub Creation_chapitre(oChap As String, oIntit As String)
Dim oRng As Range
With ThisWorkbook.Worksheets("DPGF")
'Changer le titre par le titre exact de la nouvelle page excel
Set oRng = .Cells(.Rows.Count, 1).End(xlUp)
oRng.Offset(1, 0).EntireRow.Insert
oRng.Offset(1, 0).EntireRow.Insert
oRng.Offset(2, 0) = oChap
oRng.Offset(2, 1) = oIntit
oRng.Offset(2, 0).EntireRow.Font.Color = RGB(0, 0, 0)
End With
End Sub
Sub Creation_intitule(oChap As String, oIntit As String, oRng_table As Range)
With oRng_table
.Offset(1, 0).EntireRow.Insert
.Offset(1, 0) = oChap
.Offset(1, 1) = oIntit
.Offset(1, 0).EntireRow.Font.Color = RGB(0, 0, 0)
End With
End Sub
Function Compte_point(oStr As String) As Integer
Dim i As Integer
Dim oCount As Integer
For i = 1 To Len(oStr)
If Mid(oStr, i, 1) = "." Then
oCount = oCount + 1
End If
Next i
Compte_point = oCount
End Function |
