Bonjour à tous,


Je suis dans une impasse sur l'historisation de donnée et je souhaiterais une aide extérieur part une âme qui aurait du temps.

1 - Réception des emails

2 - Envoie des fichiers joints uniquement dans un dossier local(Macro Outlook)

3 - Récupération de toutes les données des fichiers reçus dans un onglet excel(Macro Excel)

Problématique

Dans le point 2 et 3 il récupère toute l'antériorité des fichiers sans prendre en compte qu'il les a deja pris à un moment donnée.

Le problème étant qu'avec 16 fichiers par jours en quelques mois j'en suis deja à 1300, et une macro (la 2) qui envoi 1200 fichiers c'est long et comme c'est exponentielle ca ne sera encore plus dans quelques mois.

Le problème est le même dans la macro 3, au lancement de la macro il recommence à zero pour tout récupérer rebelotte les 1200 fichiers ce qui est aussi très long...


Macro 1
(J'ai crée une regle qui envoie les fichiers dans le dossier de mon choix, et au lancement de la macro envoie les fichiers joints dans un dossier excel)

Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
Sub retardrelances()
'Kill "C:\Documents and Settings\RC1194\Desktop\test\test1\**"
Outlook_Archive = "Boîte aux lettres - Anthony (FR)"
Outlook_Folder = "Boîte de réception"
Outlook_SubFolder1 = "Histo chargés"
Outlook_SubFolder2 = ""
Outlook_SubFolder3 = ""
 
Subject_InStr = ""
Get_All_Files = True
Delete_Mail = False
 
Target_Folder = "N:\Historisation\Fichiers Retard Relance\"
Target_File_Name = ""
 
 Log_File_Long_Name = "Log Yohann"
'Shell ("C:\Documents and Settings\RC1194\Desktop\test\TEST\Test appli\TEST batch trois macros.bat")
'---------------------------------
' DO NOT CHANGE THE FOLLOWING CODE ReceivedTime &
'---------------------------------
 
cpt = 0
Set objOutlook = CreateObject("Outlook.Application")
Set objFolder = objOutlook.GetNamespace("MAPI").Folders(Outlook_Archive)
 
On Error Resume Next
For i = 0 To 3
Select Case i
Case 0
If Not Outlook_Folder = "" Then
Set objFolder = objFolder.Folders(Outlook_Folder)
Else
Exit For
End If
Case 1
If Not Outlook_SubFolder1 = "" Then
Set objFolder = objFolder.Folders(Outlook_SubFolder1)
Else
Exit For
End If
Case 2
If Not Outlook_SubFolder2 = "" Then
Set objFolder = objFolder.Folders(Outlook_SubFolder2)
Else
Exit For
End If
Case 3
If Not Outlook_SubFolder3 = "" Then
Set objFolder = objFolder.Folders(Outlook_SubFolder3)
Else
Exit For
End If
End Select
Next
 
If Not Err.Number = 0 Then
Exit Sub
End If
On Error GoTo 0
 
Set objItems = objFolder.Items
For mailIndex = objItems.Count To 1 Step -1
Set objMailItem = objItems.Item(mailIndex)
If objMailItem.Attachments.Count > 0 Then
If Not InStr(1, objMailItem.Subject, Subject_InStr, 1) = 0 Then
On Error Resume Next
If Get_All_Files Then
For i = 1 To objMailItem.Attachments.Count
Set PJ = objMailItem.Attachments.Item(i)
PJ.SaveAsFile Target_Folder & PJ.DisplayName
cpt = cpt + 1
Next
Else
Set PJ = objMailItem.Attachments.Item(1)
If Target_File_Name = "" Then Target_File_Name = ReceivedTime.Value & PJ.DisplayName
PJ.SaveAsFile Target_Folder & Target_File_Name
cpt = cpt + 1
End If
If Not Err.Number = 0 Then
Exit Sub
End If
On Error GoTo 0
 
If Delete_Mail Then objMailItem.Delete
End If
End If
Next
 
'Kill "C:\Documents and Settings\RC1194\Desktop\test\test1\*Copie*"
'Kill "C:\Documents and Settings\RC1194\Desktop\test\test1\*image001.jpg*"
'Kill "N:\Historisation\Fichiers Tma Share\*FMF*"
MsgBox "Macro terminée, les fichiers ont tous été copiés sur ton ordinateur"
End Sub

Macro 2
Explication : elle est spécifique, seul 4 champs me sont utilises dans chaque fichier que je recupere dans un fichier externe
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
Sub aaaaa()
 
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 Application.Calculation = xlCalculationManual
 sousRépertoire = "Fichiers Retard Relance"
 [A2].CurrentRegion.Offset(1, 0).Clear
 Set maitre = ActiveWorkbook
 Repertoire = ThisWorkbook.Path
 nf = Dir(Repertoire & "\" & sousRépertoire & "\*.xls") ' premier fichier
Do While nf <> ""
 Workbooks.Open Filename:=Repertoire & "\" & sousRépertoire & "\" & nf
With ThisWorkbook.Sheets("Feuil1")
    derlig = .Range("A65000").End(xlUp).Row + 1
   .Range("A" & derlig) = DateSerial((Mid(Cells(1, 1), 18, 4)), (Mid(Cells(1, 1), 15, 2)), (Mid(Cells(1, 1), 12, 2)))
   .Range("B" & derlig) = Left([D7], InStr(1, [D7], " ") - 1)
   .Range("C" & derlig) = LTrim(Split([B3] & " ")(0))
   .Range("D" & derlig) = Application.Sum(Range("j1").EntireColumn) / 2
End With
 
 ActiveWorkbook.Close False
 
nf = Dir ' fichier suivant
 
 
 Loop
 Application.Calculation = xlCalculationAutomatic
ActiveWorkbook.RefreshAll
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Merci d'avance de votre aide

Cordialement,

Anthooooony