Nur E-Mailinhalte in Excel inportieren, die Exceldatei soll immer wieder mit den E-Mailinhalten ergänzt werden

Option Explicit
Option Compare Text

Private Const RowStart = 4                  'Ab Zeile 4 Anmeldungen eintragen  

Private Const SheetData = "Anmeldungen"     'Tabellenname Anmeldedaten  
Private Const SheetTemp = "Temp"            'Tabellenname Htm-Import  

Private Const MailsSubject = "*Anmeldung zum Camp*"  
Private Const HtmDataCells = "A8,A9," & _  
                             "B10,B11,B12,B13,B14,B15," & _  
                             "A18," & _  
                             "B19,B20,B21,B22,B23,B24,B25,B26,B27," & _  
                             "A28," & _  
                             "B29,B30,B31," & _  
                             "A32," & _  
                             "B33,B34,B35,B36,B37,B38,B39,B40,B41," & _  
                             "A42," & _  
                             "B43,B44,B45"  

Private Const Msg1 = "Keine Emails im Posteingang gefunden!"  
Private Const Msg2 = "Es wurden %1 neue Emails importiert!"  
Private Const Err1 = "Der Email-Import ist bei %1 von %2 Emails fehlgeschlagen!"  

Private Sub CommandButton1_Click()
    Dim oOL As Outlook.Application, oMails As Outlook.Items, oFso As Object, oMailList As Object
    Dim sKey As Variant, sFolderArchiv As String, sFileName As String
    Dim iMailsCount As Integer, iRowNext As Long, i As Integer
    
   'Archiv-Pfad für Htm-Dateien festlegen (Pfad Arbeitsmappe\Archiv)  
    sFolderArchiv = ThisWorkbook.Path & "\Archiv\"  
    
   'Set File-System  
    Set oFso = CreateObject("Scripting.FileSystemObject")  
   'Set assoziatives Array  
    Set oMailList = CreateObject("Scripting.Dictionary")  
    
   'Test ob der Archiv-Ordner schon existiert, ansonsten den Ordner neu erstellen  
    If oFso.FolderExists(sFolderArchiv) = False Then
        oFso.CreateFolder sFolderArchiv
    End If
    
   'Set Outlook-Application  
    Set oOL = CreateObject("Outlook.Application")  
   'Set Mail-Items  
    Set oMails = oOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items  
    
   'Htm-Dateien mit Email-HtmlBody erstellen  
    For i = oMails.Count To 1 Step -1
       'Test Betreff-Text Anmeldung  
        If oMails(i).Subject Like MailsSubject Then
           'Htm-Dateipfad erzeugen  
            sFileName = GetFileName(sFolderArchiv, oMails(i).ReceivedTime)
           'Mail-Item-Index als Key und Htm-Dateipfad als Item in File-Liste aufnehmen  
            oMailList.Add i, sFileName
           'Htm-Datei erstellen  
            oFso.CreateTextFile(sFileName).Write oMails(i).HTMLBody
        End If
    Next
    
    If oMailList.Count Then
       'Nächste frei Zeile in Tabellenblatt ermitteln  
        iRowNext = Cells(Rows.Count, "A").End(xlUp).Row + 1  
        
       'Wenn die Tabelle noch keine Einträge hat, dann nächste freie Zeile ist Start-Zeile  
        If iRowNext < RowStart Then iRowNext = RowStart
        
       'Anzahl Mails sichern  
        iMailsCount = oMailList.Count
       
       'Htm-Dateien importieren  
        For Each sKey In oMailList.Keys
           'Test ob Htm-Datei existiert  
            If oFso.FileExists(oMailList.Item(sKey)) Then
               'Htm-Import True: Email in Posteingang löschen / Htm-Datei in File-Liste löschen  
               'Htm-Import False: Email in Posteingang nicht löschen / Htm-Datei in Archiv löschen  
                If GetMailDataImport(oMailList.Item(sKey), iRowNext) Then
                    'oMails(sKey).Delete    'Zum Löschen der Emails, Kommentarzeichen am Anfang entfernen  
                    oMailList.Remove sKey
                    iRowNext = iRowNext + 1
                Else
                    oFso.DeleteFile oMailList.Item(sKey)
                End If
            End If
        Next
       
       'Test ob alle Htm-Dateien importiert wurden? Entsprechende Meldung ausgegeben  
        If oMailList.Count Then
            MsgBox Replace(Replace(Err1, "%1", oMailList.Count), "%2", iMailsCount), vbExclamation, "Fehler..."  
        Else
            MsgBox Replace(Msg2, "%1", iMailsCount), vbInformation, "Hinweis..."  
        End If
        
       'Temp-Sheet bereinigen  
        Call SheetTempCleanUp
    Else
        MsgBox Msg1, vbInformation, "Hinweis..."  
    End If
     
   'Outlook.App beenden  
    oOL.Quit
End Sub

'Diese Funktion importiert die Htm-Dateien in's Temp-Sheet und schreibt die Daten in die Daten-Tabelle  
Private Function GetMailDataImport(ByRef sFile, ByVal iRow As Long) As Boolean
    Dim aDataCells As Variant, aDataPlus As Variant, aDataValues As Variant
    Dim vValue As Variant, sQueryFile As String, i As Integer, p As Integer
    
   'QueryTable-Connection-File definieren  
    sQueryFile = "FINDER;File:///" & Replace(sFile, "\", "/")  
                        
    On Error Resume Next
    
   'Import Htm-Datei  
    With Sheets(SheetTemp)
        .UsedRange.Cells.Clear
         With .QueryTables.Add(Connection:=sQueryFile, Destination:=.Range("A1"))  
            .AdjustColumnWidth = True
            .WebSelectionType = xlAllTables
            .WebFormatting = xlWebFormattingNone
            .Refresh BackgroundQuery:=False
            .Delete
        End With
    End With
    
   'Test Import OK  
    If Err.Number = False Then
        GetMailDataImport = True
        
       'Htm-Zell-Adressen in Array splitten  
        aDataCells = Split(HtmDataCells, ",")  
    
       'Array für die Htm-Daten erzeugen  
        ReDim aDataValues(UBound(aDataCells) + 1)
    
       'Htm-Daten ins Daten-Array schreiben  
        With Sheets(SheetTemp)
            For i = 0 To UBound(aDataCells)
                aDataPlus = Split(aDataCells(i), "+")  
                
                vValue = .Range(Trim(aDataPlus(0))).Value
                
                For p = 1 To UBound(aDataPlus)
                    vValue = vValue & " " & .Range(Trim(aDataPlus(p))).Value  
                Next
                
                aDataValues(i) = vValue
            Next
        End With
        
       'Den Dateinamen der Htm-Datei dem Daten-Array hinzufügen  
        aDataValues(UBound(aDataValues)) = Dir(sFile)
        
       'Daten-Array in die Daten-Tabelle übernehmen  
        Cells(iRow, "A").Resize(1, UBound(aDataValues) + 1).Value = aDataValues  
    Else
        Err.Clear
    End If
End Function

'Diese Function gibt den Dateipfad einer neuen Htm-Dateipfad zurück (Dateiname enthält das Empfangsdatum)  
'Format: ArchivPfad + Jahr + Monat + Tag + 4-stellige fortlaufende Nummer ("..\Archiv\20130413_####.htm")  
Private Function GetFileName(ByRef sFolder, ByVal dDate As Date) As String
    Dim sName As String, sFileName As String, iCount As Integer
    
    sName = sFolder & Year(dDate) & Right("0" & Month(dDate), 2) & Right("0" & Day(dDate), 2) & "_"  
    
    Do: iCount = iCount + 1
        sFileName = sName & Right("000" & iCount, 4) & ".htm"  
    Loop Until Dir(sFileName) = ""  
    
    GetFileName = sFileName
End Function

'Diese Funktion entfernt Restfragmente der QueryTable-Importe und löscht die Zell-Inhalte im Temp-Sheet  
Private Sub SheetTempCleanUp()
    Dim oName As Name
    For Each oName In ThisWorkbook.Names
        If InStr(oName.Name, "ExterneDaten") > 0 Then oName.Delete  
    Next
    Sheets(SheetTemp).UsedRange.Cells.Clear
End Sub