VBA Outlook Mail verschieben

Hey Leute,
ich habe bei mir in der Firma ein kleines Problem. Wir haben in unserem Team neu eine Gemeinsame Mailadresse bekommen. Nun habe ich für jeden der 7 Team Mitglieder einen Ordner erstellt. Nun möchte ich dass wenn eine Mail in das Postfach kommt dass anhand der Betreffes die Mail entsprechend dem Team Mitglied zugeordnet wird. Wir haben dazu die Regel, dass im Betreff immer die Artikelnummer des Produktes sein muss. Ich habe dazu eine liste mit ca. 9000 Artikel Nummern die bereits entsprechend zugewiesen sind. Nun möchte ich diese über VBA so programmieren, dass die Mails mit dem entsprechenden Betreff in den Entsprechenden Ordner verschoben wird.
Beispiel:
Artikel 1-10 in Ordner Marco
Artikel 11-20 in Ordner Joel
Artikel 21-30 in Ordner Lea
Kann mir von euch jemand helfen, wie ich dies Lösen kann mit VBA? Ich möchte nicht die gesamten Artikel einzeln über die Regeln im Outlook Manuel erstellen.
Danke für eure Hilfe.
Gruss Marco

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Marko() Dim FLD As Folder, EML As MailItem Dim Art_Nr As Long, i As Long Set FLD = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) For i = 1 To 20 If FLD.Items(i).Class = olMail Then Set EML = FLD.Items(i) Art_Nr = Val(Split(EML.Subject)(0)) If Art_Nr Then MsgBox Art_Nr End If Next i End Sub

Sub Marko() Dim RegEx As Object: Set RegEx = CreateObject("vbscript.regexp") Dim FLD As Folder, EML As MailItem Dim Art_Nr As Long, i As Long, RR As Object Const Micros As String = "qwe 10126629 fnwf" RegEx.Pattern = "\d{8}" Set RR = RegEx.Execute(Micros) Debug.Print RR(0) Set FLD = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) For i = 1 To 20 If FLD.Items(i).Class = olMail Then Set EML = FLD.Items(i) Art_Nr = Val(Split(EML.Subject)(0)) If Art_Nr Then MsgBox Art_Nr End If Next i End Sub

Für mein Outlook mit 3 Accounts habe ich jetzt alle Komponente zusammen. Der Name wird aus der Excel-Datei ausgelesen und die Mail wird verschoben. Da ich keine Ordner angelgen wollte, immer in "Drafs"


Sub Marko()
Dim RegEx As Object: Set RegEx = CreateObject("vbscript.regexp")
Dim Acc As Account, FLD As Folder, Ziel As Folder, EML As MailItem
Dim WB As Object
Dim Art_Nr As Long, Nm As String, i As Long, RR As Object
Const Micros As String = "qwe 10126629 fnwf"
'Debug.Print Session.Accounts(3).DisplayName
Set WB = GetObject(Environ("userprofile") & "\desktop\Mappe1.xlsx")  '157124.xlsx")
RegEx.Pattern = "\d{8}"
Set RR = RegEx.Execute(Micros)
Debug.Print RR(0)
Nm = WB.sheets(1).Columns(1).Find(RR(0)).Offset(, 1).Value  'Name
Debug.Print Nm
'Set FLD = GetNamespace("MAPI").Folders(Session.Accounts(3).DisplayName).GetDefaultFolder(olFolderInbox)
Set FLD = Session.Folders.Item(Session.Accounts(3).DisplayName).Folders("Posteingang")
Set Ziel = FLD.Folders("Drafts")
For i = FLD.Items.Count To 1 Step -1
If FLD.Items(i).Class = olMail Then
Set EML = FLD.Items(i)
Set RR = RegEx.Execute(EML.Subject)
Debug.Print RR.Count
If RR.Count > 0 Then Art_Nr = Val(RR(0))
If Art_Nr > 0 Then EML.Move Ziel
Art_Nr = 0
End If
Next i
End Sub

Mehr Arbeit möchte ich mir so als kostenlose Unterstützung für Gröst-Händler nicht machen.

Sub Marko() 'verschiebt Mails in den Ordner des nach Artikel-Nr. zuständigen MA 'Betreff: 8-stellige Zahl: qwe 10126629 fnwf Dim RegEx As Object Set RegEx = CreateObject("vbscript.regexp") RegEx.Pattern = "\d{8}" Dim Acc As Account, FLD As Folder, Ziel As Folder, EML As MailItem Dim WB As Object Dim Art_Nr As Long, Nm As String, i As Long, RR As Object Set WB = GetObject(Environ("userprofile") & "\desktop\Mappe1.xlsx") '157124.xlsx") 'set fld = getnamespace("MAPI").GetDefaultFolder(olFolderInbox) 'Normalfall Set FLD = Session.Folders.Item(Session.Accounts(3).DisplayName).Folders("Posteingang") For i = FLD.Items.Count To 1 Step -1 'ExChange: 1 to .count If FLD.Items(i).Class = olMail Then Set EML = FLD.Items(i) Set RR = RegEx.Execute(EML.Subject) If RR.Count > 0 Then Nm = WB.sheets(1).Columns(1).Find(RR(0)).Offset(, 1).Value 'Name Set Ziel = FLD.Folders(Nm) EML.Move Ziel End If End If Next i End Sub

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Outlook Mail verschieben

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread