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
| 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
'Problème ici
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("Feuil3")
'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("Feuil3")
'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
'rien changé
oRng.Offset(2, 0) = oChap
oRng.Offset(2, 1) = oIntit
'Les 2 derniere lignes modifient l'écart
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 |
Partager