Process too long for counting received,sent mails etc. with Outlook

Hello,

My program works fine. It just takes a lot of time when running.

Could anyone give me any advice on how to simplify it so that it can be quicker?

Thank you in advance.

Code:

---

' Ignore the comments, it's in french:)
Option Explicit
Public dd As Date, df As Date
Public dateFiltre As Date
Dim i As Long
Dim MailBoxName As String
Dim OlApp As Object
Dim olFolder As Outlook.Folder
Dim myNamespace As Outlook.Namespace
Dim cellDate As Range
Dim cellStatus As Range
Dim cellObject As Range
Dim cellDossier As Range
Dim cellCategory As Range
Dim cellCC As Range
Dim cellHour As Range
Dim cellExp As Range
Dim cellRecept As Range
Dim cellReadNotRead As Range
Dim cc As Long
Dim ch As Long
Dim ce As Long
Dim cr As Long
Dim crnr As Long
Dim cd As Long
Dim cs As Long
Dim co As Long
Dim ccat As Long
Dim cdir As Long
Dim nbLines As Long
Dim nbColumns As Long
Dim col As String
Dim nbRecu As Long
Dim nbSent As Long
Dim nbNoCat As Long
Dim nbNoCatOld As Long
Dim nbUnRead As Long
Dim inbox As Boolean
Dim env As Boolean
Dim del As Boolean
Dim minDate As String
Dim jour As String
Dim mois As String
Dim annee As String

'deux macros pour accelerer l execution de la macro principale:ini_sub et fin_sub
Public Sub ini_sub()
    Application.ScreenUpdating = False 'rafraichissement ecran (pour ne pas voir défiler les macros)
    Application.Calculation = xlCalculationManual ' supprime calcul auto EXCEL pour gagner du temps.  A remettre dans fin_sub
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
End Sub
Public Sub fin_sub()
    Application.ScreenUpdating = True 'rafrfraichissement ecran
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True
End Sub
Function LettreColonne(c As Long) As String
Dim reste As Long
Dim quotient As Long
quotient = Int(c / 26)
reste = c Mod 26
If quotient = 0 And reste = 0 Then
    Exit Function
End If
If quotient = 0 Then
    LettreColonne = Chr(64 + reste)
Else
    If reste = 0 Then
        quotient = quotient - 1
        If quotient = 0 Then
            LettreColonne = Chr(64 + 26)
        Else
            LettreColonne = Chr(64 + quotient) & Chr(64 + 26)
        End If
    Else
        LettreColonne = Chr(64 + quotient) & Chr(64 + reste)
    End If
End If
End Function
Sub Sous_Dossier(olFolder As Outlook.Folder, dd As Date, df As Date)
Dim Folder As Outlook.Folder
Dim olFldr As Outlook.Folder
Dim sourceFolder As Outlook.Folder
Dim msg As Outlook.MailItem
Dim it As Outlook.Items
Dim j As Long
Dim dateR As Date
Dim d As Date
j = 1
For Each Folder In olFolder.Folders
    If Not Folder Is Nothing Then
        'appel à la macro dossier
        dossier Folder
    Else
        Exit Sub
    End If
Next Folder
End Sub
Sub dossier(olFolder As Outlook.Folder)
Dim Folder As Outlook.Folder
Dim msg As Outlook.MailItem
Dim j As Long
Dim dateR As Date
Dim d As Date
Dim h As Date
Dim NumeroJour As Integer
Dim nomDos As String
Dim s As Boolean
'''''''''''''''''''
Dim cellCC As Range
Dim cellHour As Range
Dim cellExp As Range
Dim cellRecept As Range
Dim cellReadNotRead As Range
Dim cc As Long
Dim ch As Long
Dim ce As Long
Dim cr As Long
Dim crnr As Long
'''''''''''''''''''''''''''
j = 1
Set cellCC = ThisWorkbook.Worksheets("MAIN").Cells.Find("CC", lookat:=xlWhole)
cc = cellCC.Column
Set cellHour = ThisWorkbook.Worksheets("MAIN").Cells.Find("HOUR", lookat:=xlWhole)
ch = cellHour.Column
Set cellExp = ThisWorkbook.Worksheets("MAIN").Cells.Find("SENDER", lookat:=xlWhole)
ce = cellExp.Column
Set cellRecept = ThisWorkbook.Worksheets("MAIN").Cells.Find("RECEIVER", lookat:=xlWhole)
cr = cellRecept.Column
Set cellReadNotRead = ThisWorkbook.Worksheets("MAIN").Cells.Find("READ\NOTREAD", lookat:=xlWhole)
crnr = cellReadNotRead.Column
Set cellDate = ThisWorkbook.Worksheets("MAIN").Cells.Find("DATE", lookat:=xlWhole)
cd = cellDate.Column
Set cellDossier = ThisWorkbook.Worksheets("MAIN").Cells.Find("DOSSIER", lookat:=xlWhole)
cdir = cellDossier.Column
Set cellStatus = ThisWorkbook.Worksheets("MAIN").Cells.Find("STATUS", lookat:=xlWhole)
cs = cellStatus.Column
Set cellObject = ThisWorkbook.Worksheets("MAIN").Cells.Find("SUBJECT", lookat:=xlWhole)
co = cellObject.Column
Set cellCategory = ThisWorkbook.Worksheets("MAIN").Cells.Find("CATEGORY", lookat:=xlWhole)
ccat = cellCategory.Column
If olFolder.Items.Count > 0 Then
        Do While True
            If TypeOf olFolder.Items(j) Is MailItem Then
                   
                Set msg = olFolder.Items(j)
                dateR = msg.ReceivedTime
                d = Format(dateR, "dd/mm/yyyy")
                h = Format(dateR, "hh:mm")
                NumeroJour = Weekday(d, vbMonday)
                'filtrer les mails ne pas afficher ceux reçus samedi ou dimanche
                If d > dd And d < df And NumeroJour <> 6 And NumeroJour <> 7 Then
                    ThisWorkbook.Worksheets("MAIN").Cells(i, cd) = d
                    s = msg.Sent
                    ThisWorkbook.Sheets("MAIN").Cells(i, cdir).Value = msg.Parent.Name
                    ThisWorkbook.Sheets("MAIN").Cells(i, co).Value = msg.Subject
                    ThisWorkbook.Sheets("MAIN").Cells(i, ccat).Value = msg.Categories
                    ThisWorkbook.Sheets("MAIN").Cells(i, cc).Value = msg.cc
                    ThisWorkbook.Sheets("MAIN").Cells(i, ce).Value = msg.SenderName
                    ThisWorkbook.Sheets("MAIN").Cells(i, cr).Value = msg.ReceivedByName
                    ThisWorkbook.Sheets("MAIN").Cells(i, ch).Value = h
                   
                    If msg.unRead = True Then
                        ThisWorkbook.Sheets("MAIN").Cells(i, crnr).Value = "Not Read"
                        nbUnRead = nbUnRead + 1
                    Else
                        ThisWorkbook.Sheets("MAIN").Cells(i, crnr).Value = "Read"
                    End If
                                       
                    If olFolder.Name = "Sent Items" Then
                        If s = True And d = dateFiltre Then
                            ThisWorkbook.Sheets("MAIN").Cells(i, cs).Value = "Sent"
                            nbSent = nbSent + 1
                        Else
                            ThisWorkbook.Sheets("MAIN").Cells(i, cs).Value = "Brouillon"
                        End If
                    Else
                        ThisWorkbook.Sheets("MAIN").Cells(i, cs).Value = "Received"
                        If d = dateFiltre Then
                            nbRecu = nbRecu + 1
                        End If
                       
                        If olFolder.Name Like "Inbox" And msg.Categories Like "" Then
                        'compter le nbr de msg sans category recus a la date dateFiltre
                            nbNoCat = nbNoCat + 1
                            If nbNoCat = 1 Then
                                minDate = dateR
                            ElseIf nbNoCat > 0 Then
                                If dateR < minDate Then
                                    minDate = dateR
                                End If
                            End If
                        End If
                    End If
                    i = i + 1
                    j = j + 1
                    If j > olFolder.Items.Count Then
                        Exit Do
                    End If
                Else
                    j = j + 1
                    If j > olFolder.Items.Count Then
                        Exit Do
                    End If
                End If
            Else
                j = j + 1
                If j > olFolder.Items.Count Then
                    Exit Do
                End If
            End If
        Loop
                 
End If
nomDos = olFolder.Name
'appel à la macro ss dossier
Sous_Dossier olFolder, dd, df
End Sub
'routine pour calculer le nombre de mails dans le dossier Sent Items
Sub DossierSent(olFolder As Outlook.Folder)
Dim Folder As Outlook.Folder
Dim msg As Outlook.MailItem
Dim it As Outlook.Items
Dim j As Long
Dim dateR As Date
Dim d As Date
Dim nomDos As String
Dim s As Boolean
j = 1
If olFolder.Items.Count > 0 Then
        Do While True
            If TypeOf olFolder.Items(j) Is MailItem Then
                         
                Set msg = olFolder.Items(j)
                dateR = msg.ReceivedTime
                d = Format(dateR, "dd/mm/yyyy")
               
                'filtrer les mails, compter ceux envoyes a la date d
                If d = dateFiltre Then
                    If j = olFolder.Items.Count Then
                        If env Then
                            nbSent = nbSent + 1
                        End If
                        Exit Do
                    Else
                      If env Then
                            nbSent = nbSent + 1
                        End If
                    End If
                    j = j + 1
                Else
                   
                    If j = olFolder.Items.Count Then
                        Exit Do
                    End If
                    j = j + 1
                End If
            Else
               
                If j = olFolder.Items.Count Then
                    Exit Do
                End If
                j = j + 1
            End If
        Loop
                 
End If
nomDos = olFolder.Name
'appel à la macro ss dossier
Sous_DossierSent olFolder, dd, df
End Sub
'routine pour parcourir les sous dossiers du dossier Sent Items
Sub Sous_DossierSent(olFolder As Outlook.Folder, dd As Date, df As Date)
Dim Folder As Outlook.Folder
Dim olFldr As Outlook.Folder
Dim sourceFolder As Outlook.Folder
Dim msg As Outlook.MailItem
Dim it As Outlook.Items
Dim j As Long
Dim dateR As Date
Dim d As Date
j = 1
For Each Folder In olFolder.Folders
    If Not Folder Is Nothing Then
        'appel à la macro dossier
        DossierSent Folder
    Else
        Exit Sub
    End If
Next Folder
End Sub
'Date Debut Cellule G5 Onglet MAIN
'Date Debut Cellule G7 Onglet MAIN
'Date FILTRE Cellule B2 Onglet FILTRE
Sub main()
Call ini_sub
i = 2
dd = ThisWorkbook.Worksheets("FILTRE").Range("B1").Value
df = ThisWorkbook.Worksheets("FILTRE").Range("B2").Value
dateFiltre = ThisWorkbook.Sheets("FILTRE").Range("B3").Value
nbSent = 0
nbNoCat = 0
nbRecu = 0
nbNoCatOld = 0
Set OlApp = CreateObject("Outlook.Application")
Set myNamespace = OlApp.GetNamespace("MAPI")
'MailBoxName = "Mailbox - MAACHE Amira (EXT) OperCorTpl"
MailBoxName = "Mailbox - Par-Coos-Edm-Dma-Fpv-Low"
nbLines = ThisWorkbook.Sheets("MAIN").Range("A" & Rows.Count).End(xlUp).Row
nbColumns = ThisWorkbook.Worksheets("MAIN").Rows(1).Find(What:="*", After:=ThisWorkbook.Worksheets("MAIN").Range("A1"), SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
col = LettreColonne(nbColumns)
If nbLines > 1 Then
    ThisWorkbook.Sheets("MAIN").Range("A2" & ":" & col & nbLines).Clear
End If
Set olFolder = myNamespace.Folders(MailBoxName)
Dim dos As Outlook.Folder
For Each dos In olFolder.Folders
'nbRecu dans tous les dossiers sauf Sent Items
    If dos.Name = "Inbox" Or dos.Name = "Configuration" Or dos.Name = "Deleted Items" Or dos.Name = "Folders" Or dos.Name = "Sent Items" Then
        If dos.Name = "Inbox" Then
            inbox = True
            Else
            inbox = False
       
        End If
        If dos.Name = "Sent Items" Then
            env = True
        Else
            env = False
        End If
       
        'parcours du dossier inbox et calcul de nbNoCat
        dossier dos
    End If
 
Next dos

jour = Day(minDate)
mois = Month(minDate)
annee = Year(minDate)
ThisWorkbook.Sheets("MAIN").Range("D:D").WrapText = True
ThisWorkbook.Sheets("FILTRE").Range("B8").Value = nbUnRead
ThisWorkbook.Sheets("FILTRE").Range("B7").Value = Format(minDate, "dd/mm/yyyy") 'jour & "/" & mois & "/" & annee
ThisWorkbook.Sheets("FILTRE").Range("B6").Value = nbNoCat
ThisWorkbook.Sheets("FILTRE").Range("B5").Value = nbSent
ThisWorkbook.Sheets("FILTRE").Range("B4").Value = nbRecu
Set olFolder = myNamespace.Folders(MailBoxName)
For Each dos In olFolder.Folders
'nbRecu dans tous les dossiers sauf Sent Items
    If dos.Name = "Inbox" Or dos.Name = "Configuration" Or dos.Name = "Deleted Items" Or dos.Name = "Folders" Or dos.Name = "Sent Items" Then
        If dos.Name = "Inbox" Then
            inbox = True
            Else
            inbox = False
       
        End If
        If dos.Name = "Sent Items" Then
            env = True
        Else
            env = False
        End If
       
        'parcours du dossier inbox et calcul de nbNoCat
        dossierOld dos
    End If
Next dos
ThisWorkbook.Sheets("FILTRE").Range("B9").Value = nbNoCatOld
Call fin_sub
End Sub
Sub dossierOld(olFolder As Outlook.Folder)
Dim Folder As Outlook.Folder
Dim msg As Outlook.MailItem
Dim j As Long
Dim dateR As Date
Dim d As Date
Dim NumeroJour As Integer
Dim nomDos As String
Dim isMinDate As Boolean
 
'And dateR = Format(minDate, "dd/mm/yyyy")
j = 1
If olFolder.Items.Count > 0 Then
        Do While True
            If TypeOf olFolder.Items(j) Is MailItem Then
                   
                Set msg = olFolder.Items(j)
                dateR = msg.ReceivedTime
                NumeroJour = Weekday(d, vbMonday)
                isMinDate = (Format(dateR, "dd/mm/yyyy") = Format(minDate, "dd/mm/yyyy"))
                d = Format(dateR, "dd/mm/yyyy")
               
              If isMinDate Then
     
                    If olFolder.Name Like "Inbox" And msg.Categories Like "" Then
                        'compter le nbr de msg sans category recus a la date dateFiltre
                        nbNoCatOld = nbNoCatOld + 1
               
                    End If
                    i = i + 1
                    j = j + 1
                    If j > olFolder.Items.Count Then
                        Exit Do
                    End If
                Else
                    j = j + 1
                    If j > olFolder.Items.Count Then
                        Exit Do
                    End If
                End If
            Else
                j = j + 1
                If j > olFolder.Items.Count Then
                    Exit Do
                End If
            End If
        Loop
                 
End If
nomDos = olFolder.Name
'appel à la macro ss dossier
Sous_DossierOld olFolder, dd, df
End Sub
Sub Sous_DossierOld(olFolder As Outlook.Folder, dd As Date, df As Date)
Dim Folder As Outlook.Folder
Dim j As Long
j = 1
For Each Folder In olFolder.Folders
    If Not Folder Is Nothing Then
        'appel à la macro dossier
        dossierOld Folder
    Else
        Exit Sub
    End If
Next Folder
End Sub

---