Need to add from emaill addresss as well - Import mails from outlook to excel

Hi

I have this code to export emails from outlook to excel... however there is a small issue…
I want to tweet this code to import “From email address” as well and paste the output from the fourth row say A5 in the excel

Sub ExportToExcel()

     On Error GoTo ErrHandler
     
     Dim appExcel As Excel.Application
     Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet

Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
    strSheet = "OutlookItems.xlsx"
    strPath = "C:\Users\kkumark\Desktop\"
strSheet = strPath & strSheet

Debug.Print strSheet
    'Select export folder
    Set nms = Application.GetNamespace("MAPI")
    Set fld = nms.PickFolder
    
'Handle potential errors with Select Folder dialog box.

If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub

ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
                MsgBox "There are no mail messages to export", vbOKOnly, _
    "Error"
Exit Sub
End If

    'Open and activate Excel workbook.
    Set appExcel = CreateObject("Excel.Application")
    appExcel.Workbooks.Open (strSheet)
    
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)

wks.Activate
appExcel.Application.Visible = True

'Copy field items in mail folder.

For Each itm In fld.Items
intColumnCounter = 1

Set msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.To
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SenderEmailAddress
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.ReceivedTime
Next itm
    Set appExcel = Nothing
    Set wkb = Nothing
Set wks = Nothing

Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler: If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, _
"Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, _
"Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub

Looking forward for your help

Regards
Kiran Kumar

Also can we import only those mails specific to time period… I mean can we add a pop box for the dates to feed in and the export the necessary emails to excel

Here we go the problem solved... I have just tweeted macro at sendEmailaddress to Sender name... below is how the code looks

Sub ExportToExcel()

     On Error GoTo ErrHandler
     
     Dim appExcel As Excel.Application
     Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet

Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
    strSheet = "OutlookItems.xlsx"
    strPath = "C:\Users\kkumark\Desktop\"
strSheet = strPath & strSheet

Debug.Print strSheet
    'Select export folder
    Set nms = Application.GetNamespace("MAPI")
    Set fld = nms.PickFolder
    
'Handle potential errors with Select Folder dialog box.

If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub

ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
                MsgBox "There are no mail messages to export", vbOKOnly, _
    "Error"
Exit Sub
End If

    'Open and activate Excel workbook.
    Set appExcel = CreateObject("Excel.Application")
    appExcel.Workbooks.Open (strSheet)
    
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)

wks.Activate
appExcel.Application.Visible = True

'Copy field items in mail folder.

For Each itm In fld.Items
intColumnCounter = 1

Set msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.To
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SenderName
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.ReceivedTime
Next itm
    Set appExcel = Nothing
    Set wkb = Nothing
Set wks = Nothing

Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler: If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, _
"Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, _
"Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub