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

[FrancisZheng]

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.

' 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

[p45cal]

I will look at this in more depth tomorrow, however, in haste, below I have:

• commented-out what I think is unnecessary/unused,
• changed one bit of code (LettreColonne - it may have no effect as it may not be called often),
• added one or two comments.

I can't test.
I doubt the changes so far will make any impact on speed.
How long does it actually take?

Next I'll look at the logic/algorithms/using With..End With; for example in sub dossier you have many references to ThisWorkbook.Worksheets("MAIN"). Every time you use this Excel has to resolve it, so using With ThisWorkbook.Worksheets("MAIN") and later End With, then removing all instances of ThisWorkbook.Worksheets("MAIN") within (leaving the dot) may speed it up since Excel only has to resolve it once.

In the same sub you have a whole series of pairs of lines thus:

Set cellCC = ThisWorkbook.Worksheets("MAIN").Cells.Find("CC", lookat:=xlWhole)
cc = cellCC.Column

There is no error checking so there may be no need to set up an object variable cellCC (it's not used elsewhere), instead use the single line:

cc = ThisWorkbook.Worksheets("MAIN").Cells.Find("CC", lookat:=xlWhole).column

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

'The following are also Dimmed in dossier and used exclusively there:
'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  'could this one be Dimmed in dossier?
Dim co As Long  'could this one be Dimmed in dossier?
Dim ccat As Long  'could this one be Dimmed in dossier?
Dim cdir As Long  'could this one be Dimmed in dossier?

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
LettreColonne = Split(Cells(1, c).Address, "$")(1)
'    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

[FrancisZheng]

Hi P45cal,

thank you for answering me so quickly.

I'll look at your modification the first thing tomorrow morning.

Regards,
Francis.

[FrancisZheng]

Hi P45cal,

I adapted some simplification of the code and kept the integrality of the code for further use. Thanks a lot.

I found a way to save time to great extent. But I don't know how to write the code.

The idea is to keep all the data in the MAIN sheet and add new data to it. During the execution, the code will delete the data of yesterday since it may not be complete(for ex : last time I lanced the program was yesterday noon, so the mails of yesterday's afternoon weren't copied) and then start copying from debut yesterday.

Unfortunately, this is a code from another person, so I don't know to where to modify the code. So if you have any idea, please give me some ideas.

[snb]

Reduce reading/writing from/to a worksheet to the minimum.
Use arrays to store data temporarily.

[p45cal]

OK, I think huge improvements can be made; there are unused macros, unused variables, unrequired multiple execution of lots of code, unusual recursion. It's going to be quicker to re-write from scratch than try to 'adjust' your code, so I will have questions as I develop this. Please answer all the questions, and if you don't know the answer to any, say so rather than ignore it.
1. What is the header on sheet MAIN column D?
2. Do you intend ALWAYS to have the table start in column A?
3. Your code is written in such a way that the column headers: CC,HOUR,SENDER,RECEIVER,READ\NOTREAD,DATE,DOSSIER,STATUS,SUBJECT,CATEGORY can each be in any column on the MAIN sheet, even with other column headers or blank columns inbetween. Do you want to keep this facility? (I suppose here I'm asking whether in reality the 10 columns are all next to each other, for example in columns A to J?) The reason I ask is that I want to avoid writing to the sheet one cell at a time (because it takes time), instead I want to write to the sheet in blocks, and I can write the full width of the table in one hit, or column by column. It doesn't make a lot of difference to the time, but it does make a difference to the code.

That's enough for now.

[FrancisZheng]

Hello P45cal,

I thought it would be better to start from scratch too, so I starteda new thread here :

vbaexpress.com/forum/showthread.php?58526-Retrieve-data(Time-From-subject-category)-from-Outlook-inbox-to-Execl

In the first sheet, there will be counts of sent mails, received mails and mails without category.
In the second sheet, there will be data of all received and sent mails like this :

date hour status folder subject category read/not read cc receiver sender
...

Since there are thousands of mails that need to be retrieved, the best way is to just retrieve the new mails since the last exection of the macro so we don't have to repeat copying old mails and waste time.

To your 3 questions P45cal :
1. folder(for ex : Deleted Items) I listed all the columns î.
2. Yes, the date is column A, then hour...
3. Yes, all the columns are one to another which starts from column A, if there is no information, then a cell is blank.
The first line of the sheet is titile, then the data starts from the secod line.

Thank you so much for willing to take your precious time and help me with the work which is very important to my job.

Regards,
Francis

[p45cal]

Thank you Francis, that makes things easier.
Now for some more. I'm trying to determine the intention behind various things:
1. The date in B3 of sheet FILTRE?
2. cell B9 of the same sheet (nbNoCatOld)

(Personally, I think there's only a 50/50 chance that the results you get are what you think they are!)

[FrancisZheng]

Hello P45cal,

For your questions :

1. I think it was for user to put the date of the last exection of the macro. But it's not useful anymore. We kind of hope it can be done automaticaly.

2. The cell isn't used anymore. We can just delete it.

This is indeed a tricky project !

Regards,
Francis

[FrancisZheng]

Actually I was wrong. For the second question, the cell is for the number of the date of the oldest uncategorized mail(s). For ex : the oldest uncategorized mails were 01/01/2017, and there were 3 uncategorized mails that day. So the cell B9 will show the value 3.

[p45cal]

The attached has a macro main which you should run after adusting the two dates in cells B1 and B2 of the FILTRE sheet - keep the dates close to each other to start with (one or two days apart) in order to assess speed.
It is not finished!
There are comments on the FILTRE sheet, and a few in the code.
Where I have put 'Not in use' I'll wait for clarification from you as to what you want exactly.

It could be tweaked to add only the latest data but that might get complicated, especially, for example if an email's Status changes (even an old one) but you've already brought it over into Excel. Currently it wipes the sheet as before and repopulates it.

I did ask before, how long does the process typically take using the original code?

[FrancisZheng]

Hello P45cal,

I just woke up(in France). I read your code and then tried to run the macro "main". But it says "Compile error : Can't find project or Library". It's microsoft 14.0 object library that is missing. I searched on the internet, it seems that using late binding might be the only solution. Do you have an idea on how to fix this?

Sorry I didn't answer before. It took me two hours or more to run the process. In fact, the file is used every monday to wednesday morning at the meeting when we arrive at work. Since we have to turn off everything after work and we don't have two hours before the meeting, we won't have all the data we need during the meeting. So that's the big problem we are having.

Thank you so much.

Regards,
Francis

[snb]

Wouldn't it be better to hire a consultant at your place ?

[FrancisZheng]

I hope I could but I can't. I'm still an intern engineer...

[p45cal]

I read your code and then tried to run the macro "main". But it says "Compile error : Can't find project or Library". It's microsoft 14.0 object library that is missing. I searched on the internet, it seems that using late binding might be the only solution.

In the VBE (Visual Basic Editor), Tools|References… Untick the Missing Microsoft Outlook 14.0 Object library, and scroll down until you find another Microsoft Outlook nn.n Object Library, tick it and OK. Try again.
If you just woke up you were at home? It could be that the correct library is present at work.
Yes late binding is possible, but your original code was early binding so it shouldn't be necessary.

[FrancisZheng]

Hello P45cal,

You are right. I tried and It worked well this time except there's nothing in the category column...

I also got a response from another thread which can add new data since the last execution of the macro to the main sheet. If you could somehow combine this with the program, I think the work is succeeded.

vbax_58526_retrieve_email_info_after_date.xlsm

Regards,
Francis

[p45cal]

I tried and It worked well this time

How well? How long did it take to do the about the same size of task that took 2 hours before?

except there's nothing in the category column...

then it's likely that there is no category assigned to those emails; I've just tested here and categories do appear if they are present.

i also got a response from another thread which can add new data since the last execution of the macro to the main sheet. If you could somehow combine this with the program, I think the work is succeeded.

We need to walk before we jump - there are still things to clear up with the logic. You need to address my comments in the last attachment on sheet FILTRE and be certain what dateFiltre was about as I there is more to it then " I think it was for user to put the date of the last exection of the macro. But it's not useful anymore. We kind of hope it can be done automaticaly."

Also remember what I said before:"It could be tweaked to add only the latest data but that might get complicated, especially, for example if an email's Status changes (even an old one) but you've already brought it over into Excel."

[FrancisZheng]

Hello P45cal,

How well? How long did it take to do the about the same size of task that took 2 hours before?

I only tried with a small simple and it worked well. Since we still have to copy all the data I thought the time might not change too much. I'm running and it hasn't finished yet.

then it's likely that there is no category assigned to those emails; I've just tested here and categories do appear if they are present.

Exactly, I assigned categories and it worked great.

We need to walk before we jump - there are still things to clear up with the logic. You need to address my comments in the last attachment on sheet FILTRE

The date dd and df are included in the result. nbRecu, nbSent, nbNoCat, nbNoCatOldDate, nbUnread, nbNoCatOld are exactly what you think they are, they will eventualy be used. dateFiltre means the date we want all the results in sheet one : nbRecu, nbSent, nbNoCat, nbNoCatOldDate, nbUnread, nbNoCatOld etc(so all these are just results for one day : dateFiltre).

Regards,
Francis

[p45cal]

Is dateFiltre always going to be within df and dd?

[FrancisZheng]

Is dateFiltre always going to be within df and dd?

Yes, so that there will be data for this day. dd and df won't be used evetually, but dateFiltre is always used because the data of the sheet 1 depends on its date.

Francis