VBA

Sub test()
   Dim olApp As Object, NS As Object, Dossier As Object
    Dim DossierDest As Object, DossierCible As Object

    Dim i As Object, x As Long, R As Object, Ligne As Long

    Set olApp = CreateObject("Outlook.Application")
    Set NS = olApp.GetNamespace("MAPI")
    Set Inbox = NS.GetDefaultFolder(olFolderInbox)
    Set Dossier1 = Inbox.Folders("cs-compteurs-coul")
    Set Dossier2 = Inbox.Folders("cs-compteurs-noir")
    Set DossierDest = Inbox.Folders("compteurs-OK")
With Sheets("Import Compteurs")
b = 2
Z = 2
    For Each i In Dossier1.Items

            mybody = Split(i.Body, vbCrLf)
            For compt = 0 To UBound(mybody)
            If InStr(1, UCase(mybody(compt)), UCase("Serial No.:")) > 0 Then
                Serial = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Date:")) > 0 Then
                Dat = i.CreationTime
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Total_Color:")) > 0 Then
                Couleur = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Total_BW:")) > 0 Then
                Noir = LTrim(Split(mybody(compt), ":")(1))
            End If
    Next
Dat = i.CreationTime
Cells(b, 1) = Serial
Cells(b, 2) = Dat
Cells(b, 3) = Noir
Cells(b, 4) = Couleur

b = b + 1

Z = Z + 1
Next i

d = 0
For d = 0 To Z
For Each i In Dossier1.Items
i.Move DossierDest
d = d + 1
Next i

Next




End With


End Sub