Sub ShowStatsinExcel() 
    Dim myEmail As Outlook.MailItem
    Dim Result()
    Dim objExcel As Object
    Dim objWB As Object
    Dim lngCount As Long
    'Outlook
    lngCount = Application.ActiveExplorer.Selection.Count + 1
    ReDim Result(1 To lngCount, 1 To 2)
    For Each myEmail In Application.ActiveExplorer.Selection
        Result(1, 1) = "SenderEmailAddress"
        Result(1, 2) = "ReceivedTime"
        With myEmail
            i = i + 1
            Result(i, 2) = Format(myEmail.ReceivedTime, "dd.mm.yyyy")
            Result(i, 1) = .SenderEmailAddress
        End With
    Next
 
    'Excel
    Set objExcel = CreateObject("Excel.Application")
    objExcel.Visible = True
    Set objWB = objExcel.Workbooks.Add
     Workbooks.Open ("C:\Dokumente und Einstellungen\r882948\Desktop\Mappe1.xls")
 
    With objExcel.ActiveSheet
        lngCount = lngCount - 1
        .Range("A1:B" & lngCount) = Result
        .Range("C2").FormulaR1C1 = "=RC[-2]&RC[-1]"
        .Range("D2").FormulaR1C1 = "=COUNTIF(R2C3:R" & lngCount & " C3,RC[-1])"
        .Range("C2:D2").AutoFill Destination:=Range("C2:D" & lngCount)
        .Range("C2:C" & lngCount).Value = Range("D2:D" & lngCount).Value2
        .Columns(4).Delete Shift:=xlToLeft
        .Range("C1").FormulaR1C1 = "Anzahl"
        .Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        .Columns("A:C").AutoFit
        .Range("A1").CurrentRegion.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
 
    End With
 
    Set objWB = Nothing
    Set objExcel = Nothing
 
End Sub

	Sub kopierewerte() 
    Dim gef As Range
    Range("B2:B13").Copy
    Sheets("Tabelle2").Select
    Set gef = Cells.Find ("????")
    If Not gef Is Nothing Then
        gef.Offset(1, 0).PasteSpecial Paste:=xlValues
        Application.CutCopyMode = False
    Else
        MsgBox "Das Datum wurde nicht Gefunden"
    End If
End Sub