[XL-2016] Modification de macro pour insertion au bon endroit

Modification de macro pour insertion au bon endroit

Bonjour,

Je dispose d'une macro me permettant une récupération de la table des matière Word pour la copier dans une feuille excel.
J'aimerais la modifier pour que ces titres s'insèrent à la ligne souhaitée (a partir d'A6 sur une autre feuille)
Voici le code :

Code:

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

Pour palier à ce problème, j'ai créé une autre macro "couper - insérer" pour que les titres se mettent au bon endroit, avec une macro fusion de macro, tout se passe bien :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub Copie1()
Dim O As Worksheet
'déclare la variable O (Onglet)
Dim LD As Integer
'déclare la variable LD (Ligne Début)
Dim LF As Integer
'déclare la variable LF (Ligne Fin)
Dim P As Range
'déclare la variable PL (PLage)
 
Set O = Worksheets("Feuil3")
'définit l'onglet O
LD = O.Range("A1").End(xlDown).Row + 1
'définit la ligne du début LD
LF = O.Cells(Application.Rows.Count, "A").End(xlUp).Row + 1
'définit la ligne de fin LF
Set PL = O.Range(O.Cells(LD, 1), O.Cells(LF, 2))
'définit la plage PL
PL.Cut
'copy la plage PL
Sheets("Feuil2").Range("A6").Insert Shift:=xlDown
'insere la plage pL à partir de cellule A6 de l'onglet "Feuil2"
Sheets("Feuil2").Select
End Sub

Mon problème est que je dois rentrer les titres chapitres par chapitres, et que si j'utilise la macro qui fusionne ces deux macro sur le chapitre 1, il se copiera à la bonne place sans problème, en revanche en copiant le chapitre 2, il s’insérera avant le chapitre 1, ce qui pose problème et je ne peux pas demander à tous ceux qui utiliseront cette macro de l'utiliser en prenant les chapitres de manière décroissante.
La solution pourrait être de modifier la macro de récupération pour pouvoir rentrer tous les chapitres à la fois, ainsi la macro couper/coller sélectionnerai tous les chapitres en même temps.
Autre possibilité serait de modifier la macro de récupération pour que les titres s'insèrent directement à la bonne place (A6) seulement en rentrant un autre chapitre, la bonne place ne serait plus A6.

J'espère avoir été clair dans mes explications,
Dans l'attente de vous lire,
Cordialement.

Bonjour,

En ce qui me concerne ce n'est pas clair : tu veux modifier ta macro dynamiquement à chaque exécution ? Ou tu veux que ta macro prenne un argument numéro de chapitre comme paramètre ?

Le plus simple serait de faire une boucle sur les numéros de chapitre avec un test pour vérifier si le chapitre a été traité ou non par la macro

Peut-être ?

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 
With oWksh
 
    'Copie temporaire
    .cells(1,20).PasteSpecial Format:="Texte", Link:=False, DisplayAsIcon:=False
 
    .PasteSpecial Format:="Texte", Link:=False, DisplayAsIcon:=False
    Set oRng_table = .Columns(20).Find(oChapitre, LookIn:=xlValues, LookAt:=xlWhole)
    If oRng_table Is Nothing Then
        MsgBox "Le chapitre souhaité n'est pas présent dans le document."
        Exit Sub
    End If
 
   'Copie a la bonne position
   .cells(oRng_table.row,1).select
   .PasteSpecial Format:="Texte", Link:=False, DisplayAsIcon:=False
 
  ' Effacer la copie tempraire
  .cells(1,20).entirecolumn.clear
 ...
 
End With