Outlook Macro to loop through email and add data after last row of data

MHamid

Active Member
Joined
Jan 31, 2013
Messages
472
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Hello,

I've been trying to figure out how to tweak my current Outlook Code. There are two tweaks that I need for this macro.

1) Loop through the e-mails and extract items from emails that have not been added to Sheet1 in the spreadsheet mentioned in the macro.

2) Add any additional data as needed after last row of data.

Code:
Sub EmailExtract()
'Working macro for exporting specific sub-folders of a shared inbox
Dim olMail As Variant
Dim aOutput() As Variant
Dim lCnt As Long
Dim wkb As Workbook
Dim xlApp As Excel.Application
Dim xlSh As Excel.Worksheet
Dim flInbox As Folder
Dim lastrow As Long

'Gets the mailbox and shared folder inbox
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("AAR Team Tracking")
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objInbox = objNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)
'Uses the Parent of the Inbox to specify the mailbox
strFolderName = objInbox.Parent
'Specifies the folder (inbox or other) to pull the info from
Set objMailbox = objNamespace.Folders(strFolderName)
Set objFolder = objMailbox.Folders("Inbox").Folders("Delivery - Correspondent Bank AARs").Folders("CB") 'specify folder
Set colItems = objFolder.Items
'Specify which email items to extract
ReDim aOutput(1 To objFolder.Items.Count, 1 To 10)
For Each olMail In objFolder.Items
If TypeName(olMail) = "MailItem" Then
        lCnt = lCnt + 1
        aOutput(lCnt, 1) = olMail.ReceivedTime 'stats on when received
        aOutput(lCnt, 2) = olMail.Subject 'to split out
        aOutput(lCnt, 3) = olMail.Categories 'to split out category
        aOutput(lCnt, 4) = olMail.Sender
End If
Next
'Open Excel Template
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set wkb = xlApp.Workbooks.Open("H:\jpmDesk\Desktop\Recon\Projects\2017\AAR Macro Creation\Delivery Emails Template.xlsm")
wkb.Sheets("Sheet1").Range("A2").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
xlApp.Run wkb.Name & "!SplitSubLn"

End Sub

I feel like I'm almost there, but I can't seem to figure it out.

Thank you
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop

Forum statistics

Threads
1,223,911
Messages
6,175,324
Members
452,635
Latest member
laura12345

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top