Discussion :

[JonesKCD]

Bonjour,

J'ai développé une macro dans Excel permettant d'importer certains champs de plusieurs fichiers MS Project dans une feuille Excel.

Le principe de fonctionnement : on demande à l'utilisateur de spécifier le répertoire dans lequel se trouvent les fichiers MS Project à importer dans Excel
On boucle sur tous les fichier MS Project du répertoire en n'extrayant que les champs désirés (ouverture du fichier, extraction des données, fermeture de la fenêtre MS Project)

Mon problème : L'importation fonctionne correctement à la première itération mais pour les suivantes, les fichiers MS Project sont ouverts sans que l'extraction ne se réalise. Aucun message d'erreur n'apparaît.

Le code utilisé :

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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
Option Explicit
Dim xlCell As Excel.Range
 
Sub Import_from_Suppliers_Entries()
Dim ThisWk      As Workbook
Dim Rep1        As Integer
Dim Rep2        As Integer
Dim objShell    As Object
Dim objFolder   As Object
Dim oFolderItem As Object
Dim Chemin      As String
Dim Fichier     As String
 
Set ThisWk = ThisWorkbook
 
Rep1 = MsgBox("Souhaitez-vous mettre à jour toutes les données du périmètre", vbYesNoCancel, "Mise à jour des données")
If Rep1 = vbYes Then
    Rep2 = MsgBox("ATTENTION : Les données antérieures seront toutes supprimées." & vbCrLf _
            & " Souhaitez-vous procéder à cette mise à jour ?", _
            vbYesNo + vbExclamation, _
            "Confirmation de la mise à jour des données")
    If Rep2 = vbYes Then
        Set objShell = CreateObject("Shell.Application")
        Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
 
        On Error Resume Next
        Set oFolderItem = objFolder.Items.Item
        Chemin = oFolderItem.Path
 
        If Chemin = "" Then
            MsgBox "Vous n'avez sélectionné aucun répertoire." & vbCrLf _
                    & "Le programme de mise à jour ne peut pas s'éxecuter.", _
                    vbInformation
            Exit Sub
        Else
 
            Application.ScreenUpdating = False
 
            ' On supprime les données éventuellement présente sur la feuille
            If ThisWk.ActiveSheet.UsedRange.Rows.Count >= 13 Then
                ThisWk.ActiveSheet.Range(Cells(13, 1), Cells(ThisWk.ActiveSheet.UsedRange.Rows.Count, 1)).EntireRow.Delete
            End If
            Chemin = Chemin & "\"
            Fichier = Dir(Chemin & "*.mpp") ' On boucle sur tous les fichiers MS Project
            Do While Len(Fichier) > 0
                Extract_MSP ThisWk.ActiveSheet, Chemin, Fichier
                Fichier = Dir()
            Loop
 
            Application.ScreenUpdating = True
 
        End If
    Else
        Exit Sub
    End If
 
    Set oFolderItem = Nothing
    Set objFolder = Nothing
    Set objShell = Nothing
 
End If
 
Set ThisWk = Nothing
 
End Sub
 
Sub Extract_MSP(WkSh As Worksheet, Rep As String, FichMSP As String)
Dim t           As Task
Dim pj          As MSProject.Application
Dim DerLig      As Long
Dim DebLigCopy  As Long
Dim xlApp       As Excel.Application
Dim xlBook      As Excel.Workbook
Dim xlSheet     As Excel.Worksheet
Dim Asgn        As Assignment
Dim ColumnCount As Integer
Dim Columns     As Integer
Dim Tcount      As Integer
Dim TmpSh       As Worksheet
Dim i           As Integer
Dim j           As Integer
 
Set TmpSh = ThisWorkbook.Sheets("Template")
'Ouverture de MSProject
Set pj = New MSProject.Application
pj.FileOpen Rep & FichMSP, ReadOnly:=True
pj.Visible = True   ' On affiche la fenêtre MS Project
 
With TmpSh
    DerLig = .Cells(65536, 1).End(xlUp).Row + 1
    If DerLig >= 3 Then .Rows(3 & ":" & DerLig).Delete
 
    Tcount = 0
    For Each t In ActiveProject.Tasks
        If Not t Is Nothing Then
            dwn TmpSh, 1
            xlCell = t.Name
            If t.Summary = False Then
                rgt 2
                xlCell = t.Duration
                rgt 1
                xlCell = t.Start
                rgt 2
                xlCell = t.Finish
                rgt 2
                If t.PercentComplete > 0 And t.PercentComplete <> "" Then
                    xlCell = Format(t.PercentComplete / 100, "0%")
                End If
                rgt 3
                xlCell = t.OutlineLevel
                If t.OutlineLevel > Tcount Then Tcount = t.OutlineLevel
            Else
                rgt 10
                xlCell = t.OutlineLevel
            End If
        End If
    Next t
 
    .Columns(4).NumberFormat = "dd/mm/yy;@"     ' On force le contenu des cellules au format date
    .Columns(6).NumberFormat = "dd/mm/yy;@"
 
    ' On ajoute une ligne permettant d'identifier la source des données
    .Rows(3).Insert Shift:=xlDown
    With .Cells(3, 1)
        .Value = FichMSP                        ' On saisit le nom du fichier source MS Project
        .Font.Bold = False                      ' On supprime la mise en gras de la cellule
        .HorizontalAlignment = xlLeft           ' On aligne les caractères à gauche dans la cellule
        .Resize(1, 11).Interior.ColorIndex = 37 ' On colorie les cellules en bleu
    End With
 
    ' On crée le plan en fonction du niveau hiérarchique des tâches défini dans MS Project
    For j = 1 To Tcount
        For i = 3 To .Cells(65536, 1).End(xlUp).Row
            If .Cells(i, 11).Value >= j Then .Cells(i, 1).Rows.Group
        Next i
    Next j
 
    DerLig = .Cells(65536, 1).End(xlUp).Row
    .Activate
    .Range(Cells(3, 11), Cells(DerLig, 11)).Delete ' On efface les données de niveau hierarchique
    DebLigCopy = WkSh.Cells(65536, 1).End(xlUp).Row + 1
    .Cells.Font.Size = 8    ' On définit la taille des caractères dans toutes les cellules de la feuille
 
    .Rows("3:" & DerLig).Copy        ' On copie les cellules issues de MSP Project
    WkSh.Activate
    ' On colle les cellules dans la feuille contenant le planning GFE correspondant
    WkSh.Cells(DebLigCopy, 1).PasteSpecial _
                                            Paste:=xlPasteAll, _
                                            Operation:=xlNone, _
                                            SkipBlanks:=False, _
                                            Transpose:=False
 
End With
 
pj.Quit
 
Set pj = Nothing
Set TmpSh = Nothing
 
End Sub
Sub dwn(Sh As Worksheet, i As Integer)
 
Set xlCell = Sh.Cells(65536, 1).End(xlUp).Offset(i, 0)
 
End Sub
 
Sub rgt(i As Integer)
 
Set xlCell = xlCell.Offset(0, i)
 
End Sub

Quelqu'un pourrait-il m'aider à solutionner mon problème ?

Merci à tous ceux qui voudront bien se pencher sur ce problème.