Maybe something like
Code:
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