Outlook-Makro-Code

Code (in ThisOutlookSession)

Private WithEvents olItems As Outlook.Items

Private Sub Application_Startup()

'Variablen dimensionieren
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace

'Variablen initialisieren
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olItems = olNS.GetDefaultFolder(olFolderInbox).Items

'Test
Debug.Print "Application_Startup wird ausgeführt"

End Sub

Private Sub olItems_ItemAdd(ByVal item As Object)

'Variablen dimensionieren
Dim olMail As Outlook.MailItem
Dim olAtt As Outlook.Attachment
Dim Dateipfad As String

'Prüfen, ob Item eine Mail ist
If TypeName(item) = "MailItem" Then

    Set olMail = item
    
    'Prüfen, ob Mail verwendet werden soll
    If InStr(olMail.Subject, "Test") <> 0 And _
    olMail.SenderEmailAddress = "kaiweissmann@outlook.de" Then
    
        'Daten zusammenführen
        
        'Schleife über alle Anhänge
        For Each olAtt In olMail.Attachments
        
            Dateipfad = "C:\Users\kaiwe\OneDrive\Desktop\Downloads\" & olAtt.FileName
            
            'Datei speichern
            olAtt.SaveAsFile Dateipfad
            
            'Daten zusammenführen
            Call DatenZusammenfuehren(Dateipfad)
        
        Next olAtt
        
    End If
    
    'Test
'    Debug.Print olMail.Subject
'    Debug.Print olMail.SenderEmailAddress
'    Debug.Print olMail.Attachments.Count

End If

'Bereitgestellt von VBATrainer: www.vbatrainer.de

End Sub

Sub DatenZusammenfuehren(Dateipfad As String)

'Excel-Bibliothek aktivieren

'Variablen dimensionieren
Dim xlApp As New Excel.Application
Dim wbMaster As Workbook
Dim wbSource As Workbook
Dim wsMaster As Worksheet
Dim wsSource As Worksheet

'Excel-Applikation sichtbar machen
xlApp.Visible = True

'Dateien öffnen
Set wbMaster = xlApp.Workbooks.Open("C:\Users\kaiwe\OneDrive\Desktop\MasterData.xlsx")
Set wbSource = xlApp.Workbooks.Open(Dateipfad)

Set wsSource = wbSource.Worksheets(1)
Set wsMaster = wbMaster.Worksheets(1)

'Daten kopieren und einfügen
wsSource.Range("A2:E" & wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row).Copy
wsMaster.Range("A" & wsMaster.Cells(wsMaster.Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial

'Dateien und Applikation schließen
wbMaster.Close True
wbSource.Close False
xlApp.Quit

'Bereitgestellt von VBATrainer: www.vbatrainer.de

End Sub