Problème de parcours et de tri pour outlook via Excel

Salut à toutes et tous, j'ai un soucis avec un programme que je dois réaliser. J'ai fais un programme il y a quelques temps et je dois l'améliorer. Le but de se programme est de pouvoir effectuer des statistiques sur les boites outlook d'une entreprise. Ainsi il affiche l'heure, le jour, la date, le sujet, la taille etccc en fonction du nom de la personne.
Voici le code (un peu sale je reconnais):

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
140
141
142
143
144
145
Option Explicit
 
'------------------------------------------------------------------------
'Nécessite d'activer la référence Microsoft Outlook xx.xx Object Library
'------------------------------------------------------------------------
 
Sub RecupMail()
Dim MonApplication As New Outlook.Application
Dim MonUser As Outlook.Recipient
 
Dim MonNamespace As Outlook.Namespace
Dim Dossier As Outlook.MAPIFolder
Dim Dossier2 As Outlook.MAPIFolder
Dim MonMail As Object
 
Dim ligne As Variant
Dim colonne As Variant
 
Set MonNamespace = MonApplication.GetNamespace("MAPI")
 
'Selection de la feuille Analyse pour stocker les données
Worksheets("Analyse").Select
Set MonUser = MonNamespace.CreateRecipient(Worksheets("Paramètres").Cells(2, 2))
 
 
' Résolution du User en fonction Nom et Prénom
MonUser.Resolve
 
If MonUser.Resolved = True Then
    On Error Resume Next
End If
 
 
 
ligne = 2
 
Set Dossier = MonNamespace.GetSharedDefaultFolder(MonUser, olFolderInbox)
 
Temps_Analyse = Worksheets("Analyse").Format(MonMail.ReceivedTime, "DDDD")
 
For Each MonMail In Dossier.Items
 
        colonne = 1
 
 
        Cells(ligne, colonne) = Dossier
        colonne = colonne + 1
        Cells(ligne, colonne) = Format(MonMail.ReceivedTime, "MM/DD/YYYY")
        colonne = colonne + 1
        Cells(ligne, colonne) = Format(MonMail.ReceivedTime, "HH:MM:SS")
        colonne = colonne + 1
        Cells(ligne, colonne) = Format(MonMail.ReceivedTime, "DDDD")
        colonne = colonne + 1
 
        Cells(ligne, colonne) = MonMail.SenderName
        colonne = colonne + 1
        'Si @ alors hors SEngS
        If InStr(1, MonMail.SenderEmailAddress, "@") <> 0 Then
            Cells(ligne, colonne) = "Non"
        Else
            Cells(ligne, colonne) = "Oui"
        End If
        colonne = colonne + 1
 
        Cells(ligne, colonne) = MonMail.Subject
        colonne = colonne + 1
 
        'Invitation réunion
        If MonMail.Class = olMeetingRequest Then
            Cells(ligne, colonne) = "Invitation réunion"
            colonne = colonne + 1
            Cells(ligne, colonne) = MonMail.Recipients.Count
            colonne = colonne + 1
        Else
            colonne = colonne + 1
            colonne = colonne + 1
        End If
 
        'Nombre de mot dans corps du mail
        Cells(ligne, colonne) = UBound(Split(MonMail.Body, " ")) + 1
        colonne = colonne + 1
        Cells(ligne, colonne) = MonMail.Attachments.Count
        colonne = colonne + 1
        Cells(ligne, colonne) = MonMail.Size
        colonne = colonne + 1
        Cells(ligne, colonne) = UBound(Split(MonMail.To, ";")) + 1
        colonne = colonne + 1
        Cells(ligne, colonne) = UBound(Split(MonMail.CC, ";")) + 1
        colonne = colonne + 1
        Cells(ligne, colonne) = UBound(Split(MonMail.BCC, ";")) + 1
        colonne = colonne + 1
 
        Cells(ligne, colonne) = Not (MonMail.UnRead)
        colonne = colonne + 1
 
        'Priorité
        If MonMail.Importance = olImportanceLow Then
            Cells(ligne, colonne) = "Low"
        End If
        If MonMail.Importance = olImportanceNormal Then
            Cells(ligne, colonne) = "Normal"
        End If
        If MonMail.Importance = olImportanceHigh Then
            Cells(ligne, colonne) = "High"
        End If
        colonne = colonne + 1
 
        'Direct/Reply/Reply All/ Forward
        Cells(ligne, colonne) = "Direct"
        If Left(MonMail.Subject, 4) = "RE: " Then
            Cells(ligne, colonne) = "Reply"
        End If
        If Left(MonMail.Subject, 4) = "RE: " Then
            If (UBound(Split(MonMail.To, ";")) + UBound(Split(MonMail.CC, ";")) + UBound(Split(MonMail.BCC, ";")) + 3 > 1) Then
                Cells(ligne, colonne) = "Reply All"
            End If
        End If
        If Left(MonMail.Subject, 4) = "TR: " Then
            Cells(ligne, colonne) = "Forward"
        End If
        colonne = colonne + 1
 
        'Detinataire/Unique/Copie
        If InStr(1, MonMail.To, MonUser.Name, 1) <> 0 Then
            Cells(ligne, colonne) = "Destinataire"
            If UBound(Split(MonMail.To, ";")) + 1 = 1 Then
                Cells(ligne, colonne) = "Destinataire unique"
            End If
        End If
        If InStr(1, MonMail.CC, MonUser.Name, 1) <> 0 Then
            Cells(ligne, colonne) = "Copie"
        End If
        colonne = colonne + 1
 
        'Accusé de réception
        Cells(ligne, colonne) = MonMail.ReadReceiptRequested
        colonne = colonne + 1
 
        ligne = ligne + 1
 
 
Next MonMail
 
 
End Sub

Le programme ne parcours que la boite de réception or une des améliorations est de faire parcourir tous les dossiers/sous dossiers et que dans chaque dossiers/sous dossiers les mails soient triés (cad qu'il affiche bien les bons mails dans le bon dossier dans un tableau excel). Malheureusement impossible d'y arriver, soit le tableau excel m'affiche tous les dossiers sans rien trier soit tous les mails s'affichent mais pas de dossiers.. Je suis bloquer, si vous pouvez m'aider.

Merci d'avance,

Shamix