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
| 'Déclaration constantes
Const COL = 7
'Compare fichier existant avant extraction
Sub Compare()
'Instanciation variable
Dim ProjObj As MSProject.Application
Dim T As Tasks
Dim path
Dim tache
Dim find As Boolean
Dim vrow As Integer
Dim vrowex As Integer
'Création d'un objet Project (Permet le pilotage de Project depuis Excel)
Set ProjObj = CreateObject("msproject.application")
'Ouvre une boîte de dialogue demandant à l'user de choisir son fichier Project
Fichier = Application.GetOpenFilename("Fichiers .MPP(*.mpp),*.mpp")
If Fichier = False Then Exit Sub
'Ouverture du fichier Project pour Extraction vers Excel
ProjObj.FileOpen Fichier, _
ReadOnly:=True
'Affiche ou non le fichier Project
ProjObj.Visible = False
'Ouvre le fichier excel à comparer avec le project
path = Application.GetOpenFilename("Fichiers .XLS (*.xls),*.xls, Fichiers .XLSX(*.xlsx),*.xlsx,Fichiers .XLSM (*.xlsm),*.xlsm")
If path = False Then Exit Sub
'Ouverture du fichier Excel
Workbooks.Open path
'Affiche ou non le fichier Excel
'Worksheets.Visible = False
vrowex = 2
'Parcours le tableau tant qu'une cellule de la première colonne n'est pas vide
While Worksheets("Extract de Project").Cells(vrowex, 1) <> ""
find = False
For vrow = 1 To ProjObj.ActiveProject.Tasks.Count
'Parcours du fichier afin de voir si la tâche est existante dans le fichier Excel
tache = Worksheets("Extract de Project").Cells(vrowex, 1)
If tache = ProjObj.ActiveProject.Tasks(vrow).Name Then
find = True
End If
vrowex = vrowex + 1
Next vrow
If find = False Then
'Copie la nouvelle tâche au bon endroit
With ActiveProject
SelectRow Row:=vrow - 1
EditCopy
End With
Worksheets("Extract de Project").Paste Destination:=Range(Cells(vrowex, 1), Cells(vrowex, 1))
End If
Wend
'Fermer fichier Project après comparaison
On Error Resume Next
Set Fichier = GetObject(, "MSProject.Application")
If Fichier Is Nothing Then
MsgBox "Project est fermé"
Else
'MsgBox "Project est ouvert"
'Fermeture application Project
Fichier.Quit (False)
'Libère la mémoire où est stocké l'objet project
Set ProjObj = Nothing
Set Fichier = Nothing
End If
'Fermeture et sauvegarde fichier Excel
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.ScreenUpdating = False
End Sub |
Partager