PDA

View Full Version : Outlook to Excel Table using VBA having a small issue



DekeVader
11-25-2016, 01:26 PM
Hi All!
I'm new to the forum and somewhat new to using VBA in Excel. I'm mostly self taught and not very good. I've been teaching myself by trial and error using bits of other code. One thing I'm attempting to do with my current spreadsheet is to list all of the emails in a particular set of folders. What I'm attempting to do right now is just get it to list the emails in one folder and post them over and over on the next available line rather than continually overwriting the lines in the table. Line that is giving me trouble is the following:


oRow = ActiveSheet.ListObjects("Table1").DataBodyRange.End(xlUp).Offset(1, 0).Row

And here is the full code:


'
Option Explicit
Sub VBA_Export_Outlook_Emails_To_Excel()

Dim Folder As Outlook.MAPIFolder
Dim sFolders As Outlook.MAPIFolder
Dim iRow As Integer, oRow As Integer
Dim MailBoxName As String, Pst_Folder_Name As String

MailBoxName = "Mailbox, PL-SYSTEM-OUTAGES"

Pst_Folder_Name = "Apex" 'Sample "Inbox" or "Sent Items"

'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)

For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
For Each sFolders In Folder.Folders
If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
Set Folder = sFolders
GoTo Label_Folder_Found
End If
Next sFolders
Next Folder

Label_Folder_Found:
If Folder.Name = "" Then
MsgBox "Invalid Data in Input"
GoTo End_Lbl1:
End If

ThisWorkbook.Sheets(1).Activate
Folder.Items.Sort "Received"

'Insert Column Headers
ThisWorkbook.Sheets(1).Cells(1, 1) = "Sender"
ThisWorkbook.Sheets(1).Cells(1, 2) = "Subject"
ThisWorkbook.Sheets(1).Cells(1, 3) = "Date"
ThisWorkbook.Sheets(1).Cells(1, 4) = "Size"
'ThisWorkbook.Sheets(1).Cells(1, 5) = "Body"

'Export eMail Data from PST Folder to Excel with date and time

oRow = ActiveSheet.ListObjects("Table1").DataBodyRange.End(xlUp).Offset(1, 0).Row

For iRow = 1 To Folder.Items.Count
'If condition to import mails received in last 60 days
'To import all emails, comment or remove this IF condition
If VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 60 Then
oRow = oRow + 1
ThisWorkbook.Sheets(1).Cells(oRow, 1).Select
ThisWorkbook.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
ThisWorkbook.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
ThisWorkbook.Sheets(1).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
ThisWorkbook.Sheets(1).Cells(oRow, 4) = Folder.Items.Item(iRow).Size
'ThisWorkbook.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).Body
End If
Next iRow
MsgBox "Outlook Mails Extracted to Excel"
Set Folder = Nothing
Set sFolders = Nothing

End_Lbl1:
End Sub


I know it's probably something small I'm missing but I've been doing alot of trial and error of the past 3 day's and I'm getting frustrated.
Any help would be appreicated!

Thanks!!!
-Deke

DekeVader
11-28-2016, 07:04 AM
Hi all,
Just bumping this since everyone was probably on vacation over the holiday. Any help would be greatly appreciated!

-Deke