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
|
Sub recherche_dans_dossier()
Dim MonOutlook As Outlook.Application
Dim LeMail As Object
Dim LesMails
Set MonOutlook = Outlook.Application
Set LesMails = MonOutlook.ActiveExplorer.CurrentFolder.Items
Set es = CreateObject("Excel.Application")
es.Visible = True
es.workbooks.Add
es.activesheet.Name = "res"
ligne = 1
For Each LeMail In LesMails
lachaine = LeMail.Body
Position = InStr(1, lachaine, "RES0")
jour = LeMail.CreationTime
While Position > 0
machaine = Mid(lachaine, Position, 10)
' ça bug ici
rech = es.sheets("res").Range(es.sheets("res").cells(1, 1), es.sheets("res").cells(ligne, 1)).Find(machaine, LookIn:=xlValues)
If Not rech Is Nothing Then
If es.sheets("res").cells(rech.row, 2).Value > jour Then
es.sheets("res").cells(rech.row, 2).Value = jour
End If
Else
es.sheets("res").cells(ligne, 1).Value = machaine
es.sheets("res").cells(ligne, 2).Value = jour
Debug.Print machaine
ligne = ligne + 1
End If
lachaine = Mid(lachaine, Position + 10)
Position = InStr(1, lachaine, "RES0")
Wend
machaine = 0
Next LeMail
Set LesMails = Nothing
MsgBox "Fin de traitement"
End Sub |
Partager