Sub CopyInboxMsgDataToExcel()
Dim xlApp As Object
Dim xlWb As Object
Dim xlSheet As Object
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim sFrom As String
Dim sDate As String
Dim sSubject As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim FSO As Object
Dim lCount As Long

Const strPath As String = "C:\Path\Inbox.xlsx"        'the path of the workbook

    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox "No Items selected!", vbCritical, "Error"
        Exit Sub
    End If
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Application.StatusBar = "Please wait while Excel source is opened ... "
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
    On Error GoTo 0

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not FSO.FileExists(strPath) Then
        Set xlWb = xlApp.Workbooks.Add
        Set xlSheet = xlWb.Sheets("Sheet1")
        With xlSheet
            .Range("A1").Value = "From"
            .Range("B1").Value = "Date"
            .Range("C1").Value = "CSubject"
        End With
        xlWb.SaveAs strPath
    Else
        'Open the workbook to input the data
        Set xlWb = xlApp.Workbooks.Open(strPath)
        Set xlSheet = xlWb.Sheets("Sheet1")
    End If
    xlApp.Visible = True
    Set olItems = Session.GetDefaultFolder(olFolderInbox).Items
    For lCount = olItems.Count To 1 Step -1
        Set olItem = olItems(lCount)
        If TypeName(olItem) <> "Nothing" Then
            On Error GoTo Skip
            sFrom = olItem.Sender
            sDate = CStr(olItem.SentOn)
            sSubject = olItem.Subject
            'Find the next empty line of the worksheet
            rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
            rCount = rCount + 1
            xlSheet.Range("A" & rCount) = sFrom
            xlSheet.Range("B" & rCount) = sDate
            xlSheet.Range("C" & rCount) = sSubject
            xlWb.Save
            DoEvents
        End If
Skip:
        On Error Resume Next
    Next lCount
    xlWb.Close SaveChanges:=True
    If bXStarted Then
        xlApp.Quit
    End If
    Set xlApp = Nothing
    Set xlWb = Nothing
    Set xlSheet = Nothing
    Set olItem = Nothing
    Set olItems = Nothing
lbl_Exit:
    Exit Sub
End Sub