Hallo,
ich habe ein Makro geschrieben, was meine Mails automatisch verarbeitet, sobald ein bestimmtes Wort im Betreff auftaucht. Dabei wird die angehängte Excel geöffnet und der Inhalt kopiert. Nur leider scheint es ein Performance Problem zu geben, da er erst nach mehrfachen Durchlauf auch wirklich alle Mails bearbeitet hat. Hat jemand eine Ahnung, wie man das Programm flüssiger zum Laufen bekommt, so dass gleich alle Mails berücksichtigt werden? Oder hat es VBA einfach so ansich, dass es mit größeren Datenmengen unsauber wird?
Hier mal mein Code:
ich habe ein Makro geschrieben, was meine Mails automatisch verarbeitet, sobald ein bestimmtes Wort im Betreff auftaucht. Dabei wird die angehängte Excel geöffnet und der Inhalt kopiert. Nur leider scheint es ein Performance Problem zu geben, da er erst nach mehrfachen Durchlauf auch wirklich alle Mails bearbeitet hat. Hat jemand eine Ahnung, wie man das Programm flüssiger zum Laufen bekommt, so dass gleich alle Mails berücksichtigt werden? Oder hat es VBA einfach so ansich, dass es mit größeren Datenmengen unsauber wird?
Hier mal mein Code:
PHP:
For Each mailItem In objFolder.Items
If TypeName(mailItem) = "MailItem" Then
eingangsNachrichtDatumUhrzeit = Split(mailItem.ReceivedTime, " ")
eingangsNachrichtDatum = Split(eingangsNachrichtDatumUhrzeit(0), ".")
eingangsNachrichtUhrzeit = Split(eingangsNachrichtDatumUhrzeit(1), ":")
'Prüfen ob Mail nicht außerhalb des Zeitraumes der letzten Aktualisierung liegt
'LetzteAktualiseriungJahr < Empfangsjahr --> Durchlaufen
'LetzteaktualisierungJahr = Empfangsjahr & LetzteAktualisierungMonat < Empfangsmonat --> Durchlaufen
'LetzteAktualisierungJahr = Empfangsjahr & LetzteAktualisierungMonat = Empfangsmonat & LetzteAktualisierungTag < Empfangstag --> Durchlaufen
'LetzteAktualisierungJahr = Empfangsjahr & LetzteAktualisierungMonat = Empfangsmonat & LetzteAktualisierungTag = Empfangstag & LetzteAktualisierungsstunde < Empfangsstunde --> Durchlaufen
'LetzteAktualisierungJahr = Empfangsjahr & LetzteAktualisierungMonat = Empfangsmonat & LetzteAktualisierungTag = Empfangstag & LetzteAktualisierungsstunde = Empfangsstunde & LetzteAktualiserungsminute = Empfangsminute --> Durchlaufen
If ( _
(letzteaktualisierungdatum(2) < eingangsNachrichtDatum(2)) Or _
(letzteaktualisierungdatum(2) = eingangsNachrichtDatum(2) And letzteaktualisierungdatum(1) < eingangsNachrichtDatum(1)) Or _
(letzteaktualisierungdatum(2) = eingangsNachrichtDatum(2) And letzteaktualisierungdatum(1) = eingangsNachrichtDatum(1) And letzteaktualisierungdatum(0) < eingangsNachrichtDatum(0)) Or _
(letzteaktualisierungdatum(2) = eingangsNachrichtDatum(2) And letzteaktualisierungdatum(1) = eingangsNachrichtDatum(1) And letzteaktualisierungdatum(0) = eingangsNachrichtDatum(0) And letzteAktualisierungUhrzeit(0) < eingangsNachrichtUhrzeit(0)) Or _
(letzteaktualisierungdatum(2) = eingangsNachrichtDatum(2) And letzteaktualisierungdatum(1) = eingangsNachrichtDatum(1) And letzteaktualisierungdatum(0) = eingangsNachrichtDatum(0) And letzteAktualisierungUhrzeit(0) = eingangsNachrichtUhrzeit(0) And letzteAktualisierungUhrzeit(1) < eingangsNachrichtUhrzeit(1)) _
) Then
'Betreff der Mail erfassen
Betreff = mailItem.Subject
'Wenn Betreff für die Datei zutrifft
If (InStr(1, Betreff, sachverhalt, vbTextCompare)) <> 0 Then
'Betreff aufsplitten und Datum, zu der das File gehört herausfiltern
betreff_Teile = Split(Betreff, "_")
datumDerDatei = betreff_Teile(1)
'Überprüfe, ob es die aktuellste Datei zum dazugehörigen Tag ist
Workbooks(zieldatei).Sheets(sheetNameArchiv).Activate
i = 2
'Prüfen, ob überhaupt schon ein Tag angelegt worden ist
If (Cells(i, 1).Value <> "") Then
status = True
'Durchgehen der Datumsspalte im Archiv, prüfen ob der Tag, zu dem die Mail gehört bereits vorhanden
Do While (Cells(i, 1).Value <> "")
'Wenn Tag bereits vorhanden
If (Cells(i, 1).Value = datumDerDatei) Then
'Prüfen ob die aktuell ausgewählte Mail nicht bereits veraltet ist
If (mailItem.ReceivedTime > Cells(i, 2)) Then
'Falls Tag bereits vorhanden, und die aktuell ausgewählte Mail neuer ist als der bisherige
'Datenbestand, Datum der Mail im Archiv eintragen und einlesen des Anhanges starten
Cells(i, 2).Value = mailItem.ReceivedTime
'Aktuellerer Eintrag zu diesem Datum bereits vorhanden
Else
mailItem.Move objFolderArchiv
GoTo naechsteMail
End If
Exit Do
Else
status = False
End If
i = i + 1
Loop
'Tag ist noch nicht, anlegen des Tages und Starten des Einlesens des Anhangs
If (status = False) Then
Cells(i, 1).Value = datumDerDatei
Cells(i, 2).Value = mailItem.ReceivedTime
End If
'Falls nein, anlegen des Tages im Archiv und des aktuellen Datum, starten des Einlesens des Datums
Else
Cells(i, 1).Value = datumDerDatei
Cells(i, 2).Value = mailItem.ReceivedTime
End If
'Zählen der anhänge der Mail
anzahl = mailItem.Attachments.Count
For i = 1 To anzahl
'prüfen, ob es sich um eine CSV oder XLS/XLSX handelt
If (InStr(1, mailItem.Attachments.Item(i), ".csv", vbTextCompare) Or InStr(1, mailItem.Attachments.Item(i), ".xls", vbTextCompare) Or InStr(1, mailItem.Attachments.Item(i), ".xlsx", vbTextCompare)) <> 0 Then
'speichert den Anhang zwischen im Temporären Ordner
dateiname = mailItem.Attachments.Item(i).Filename
dateipfad = zwischenSpeicherVerzeichnis & "/" & mailItem.Attachments.Item(i).Filename
mailItem.Attachments.Item(i).SaveAsFile dateipfad
'Anhang bearbeiten
'Starten von Excel und Aufruf der Datei
Workbooks.Open Filename:=zwischenSpeicherVerzeichnis & "/" & mailItem.Attachments.Item(i).Filename, Local:=True
Workbooks(dateiname).Sheets(1).Activate
anzahlReihen = Range("A1").CurrentRegion.Rows.Count
Range("A2:N" & anzahlReihen).Select
'Kopieren der Datensätze
Selection.Copy
'Wechseln zur Zieldatei
Workbooks(zieldatei).Sheets(sheetNameUebersicht).Activate
'Prüfen, ob aktuelle Datensätze zu diesem Datum vorhanden sind, falls ja, diese Löschen
i = 2
Do While (Cells(i, 12).Value <> "")
datumInZelle = Cells(i, 12).Value
datumInZelleGeteilt = Split(datumInZelle, " ")
datumInZelleGeteiltTagesdatum = Split(datumInZelleGeteilt(0), ".")
datumFormatiert = datumInZelleGeteiltTagesdatum(0) & datumInZelleGeteiltTagesdatum(1) & datumInZelleGeteiltTagesdatum(2)
If (datumFormatiert = datumDerDatei) Then
Rows(i & ":" & i).Select
Selection.Delete Shift:=xlUp
Else
i = i + 1
End If
Loop
'Einfügen in Zieldatei
anzahlReihen = Range("A1").CurrentRegion.Rows.Count
Cells(anzahlReihen + 1, 1).Select
ActiveSheet.Paste
'Zwischenspeicher Löschen und Workbook schließen
Application.CutCopyMode = False
Workbooks(dateiname).Close
'Workbook löschen aus temporären Verzeichnis
Kill dateipfad
End If
Next i
'Mail in das Archiv verschieben
mailItem.Move objFolderArchiv
End If
End If
End If
naechsteMail:
Next mailItem
vergisst viel zu viel mails.
