Discussion :

[tcheylan]

Bonjour à tous,

Dans une macro vba sur excel, il y a plusieurs lignes du type :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

With Workbooks("Nom_du_excel.xlsm")

Le problème est que j'arrive à la fin de mon code qui va servir à beaucoup de personnes dans mon entreprises, qui vont utiliser le excel, le renommer, l'exploiter pour gagner du temps.
Tout le monde ne connait pas le codage et je ne peux pas me permettre le fait que tout le monde soit obligé de rentrer dans le code à chaque renommage du fichier..

Est-il possible, à la place de "Nom_du_excel.xlsm" d'affecter une ligne de code qui permettrait d'affecter dans le code, la valeur d'une cellule par exemple, cela permettrait aux autres utilisant ce excel de seulement changer le titre dans une cellule, ce qui la changera dans le code, qui fonctionnera peu importe son titre.

Cordialement.

[Qwazerty]

Salut

Si le code a exécuter est dans le classeur il te suffit d'utiliser

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

With ThisWorkbook

++
Qwaz

[tcheylan]

Bonsoir Qwaz,
Ca parait si simple, j'essaie demain au boulot et je te fais un retour.
Merci de ta réponse,
Cordialement.

[Menhir]

Il faudrait en savoir plus sur ton code et la façon dont il est lancé, mais s'il n'utilise que le fichier dans lequel se trouve la macro, il est même sans doute possible de supprimer ces With.

[tcheylan]

Le code en question permet de copier tous les titres d'un fichier Word en fonction de son chemin, pour ce que j'en fait il fonctionne très bien et avec "With Thisworkbook", ça fonctionne aussi, merci pour votre réponse.
Pour l'instant ce code fonctionne avec une page "Util" et copie tous les titres du Word sur une autre feuille, en A1.

J'aimerais faire en sorte d'avoir une macro "Copier" et "Insérer les cellules copiées" à l'endroit ou je le souhaite.
Peut-être qu'une macro n'est pas nécessaire en modifiant seulement mon code pour qu'il s'insère à l'endroit souhaité, je vous le partage si vous voulez me dire ce que vous en pensez :

Code :

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
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

Cordialement.