I am trying output a list of everyone that has emailed me, and the count of emails they sent.
I have two email accounts set up on Outlook (account A and account B). The below VBA outputs a count of users from the inbox folder for account A.
Is there a way to retrieve this data from a folder called 'Done' for Account B?
Sub CountInboxEmailsbySender()
Dim objDictionary As Object
Dim objInbox As Outlook.Folder
Dim i As Long
Dim objMail As Outlook.MailItem
Dim strSender As String
Dim objExcelApp As Excel.Application
Dim objExcelWorkbook As Excel.Workbook
Dim objExcelWorksheet As Excel.Worksheet
Dim varSenders As Variant
Dim varItemCounts As Variant
Dim nLastRow As Integer
Set objDictionary = CreateObject("Scripting.Dictionary")
Set objInbox = Outlook.Application.Session.Accounts.Item("edr.hub#bt.com")
For i = objInbox.Items.Count To 1 Step -1
If objInbox.Items(i).Class = olMail Then
Set objMail = objInbox.Items(i)
strSender = objMail.SenderEmailAddress
If objDictionary.Exists(strSender) Then
objDictionary.Item(strSender) = objDictionary.Item(strSender) + 1
Else
objDictionary.Add strSender, 1
End If
End If
Next
Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Visible = True
Set objExcelWorkbook = objExcelApp.Workbooks.Add
Set objExcelWorksheet = objExcelWorkbook.Sheets(1)
With objExcelWorksheet
.Cells(1, 1) = "Sender"
.Cells(1, 2) = "Count"
End With
varSenders = objDictionary.Keys
varItemCounts = objDictionary.Items
For i = LBound(varSenders) To UBound(varSenders)
nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.Count).End(xlUp).Row + 1
With objExcelWorksheet
.Cells(nLastRow, 1) = varSenders(i)
.Cells(nLastRow, 2) = varItemCounts(i)
End With
Next
objExcelWorksheet.Columns("A:B").AutoFit
End Sub
Related
I have code that extracts the body of email which has the subject line "Volume data".
Let's say I have 10 emails in my inbox folder which has the subject line "Volume data".
I want to loop through all the emails, find which email has subject line "Volume data" and then extract the email body from those 10 emails.
My code is stopping at the first instance where it finds the mentioned subject.
Option Explicit
Sub impOutlookTable()
Dim wkb As Workbook
Set wkb = ThisWorkbook
Sheets("Sheet1").Cells.ClearContents
' point to the desired email
Const strMail As String = "emailaddress"
Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim x As Long, y As Long
Dim destCell As Range
Dim i As Long
Dim oItem As Object
With ActiveSheet
Set destCell = .Cells(Rows.Count, "A").End(xlUp)
End With
On Error Resume Next
Set oApp = GetObject(, "OUTLOOK.APPLICATION")
If (oApp Is Nothing) Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
On Error GoTo 0
Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox")
Set oMail = oMapi.Items(oMapi.Items.Count)
For Each oItem In oMapi.Items
If oItem.Subject = "Volume data" Then
Exit For
End If
Next oItem
If Not oItem Is Nothing Then
' get html table from email object
Dim HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable
Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.Body.innerHTML = oItem.HTMLBody
Set tables = .getElementsByTagName("table")
End With
'import in Excel
For Each table In tables
For x = 0 To table.Rows.Length - 1
For y = 0 To table.Rows(x).Cells.Length - 1
destCell.Offset(x, y).Value = table.Rows(x).Cells(y).innerText
Next y
Next x
Set destCell = destCell.Offset(x)
Next
End If
Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing
wkb.SaveAs "C:\Users\Desktop\New_email.xlsm"
End Sub
Put all of the "Action" code inside the If statement inside your loop instead of after it, and then remove the Exit For.
You will also need a counter or something so that you aren't just saving overtop of the same file for each iteration.
UNTESTED
Option Explicit
Sub impOutlookTable()
Dim iCounter As Integer
iCounter = 1
Dim wkb As Workbook
Set wkb = ThisWorkbook
Sheets("Sheet1").Cells.ClearContents
' point to the desired email
Const strMail As String = "emailaddress"
Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim x As Long, y As Long
Dim destCell As Range
Dim i As Long
Dim oItem As Object
With ActiveSheet
Set destCell = .Cells(Rows.Count, "A").End(xlUp)
End With
On Error Resume Next
Set oApp = GetObject(, "OUTLOOK.APPLICATION")
If (oApp Is Nothing) Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
On Error GoTo 0
Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox")
Set oMail = oMapi.Items(oMapi.Items.Count)
For Each oItem In oMapi.Items
If oItem.Subject = "Volume data" Then
' get html table from email object
Dim HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable
Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.Body.innerHTML = oItem.HTMLBody
Set tables = .getElementsByTagName("table")
End With
'import in Excel
For Each table In tables
For x = 0 To table.Rows.Length - 1
For y = 0 To table.Rows(x).Cells.Length - 1
destCell.Offset(x, y).Value = table.Rows(x).Cells(y).innerText
Next y
Next x
Set destCell = destCell.Offset(x)
Next
Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing
wkb.SaveAs "C:\Users\Desktop\New_email_" & iCounter & ".xlsm"
iCounter = iCounter + 1
End If
Next oItem
End Sub
I currently have a code set up to add an appointment to Outlook if a cell in Excel contains the word "No". What I would like to be able to do is delete an existing appointment if the same cell is changed to "N/A". I've tried to adapt some code I found elsewhere for this but can't get it to work, currently it's displaying "Compile error: next without for"
Sub DeleteCalendarItems()
Dim r As Long, i As Long, wb As Workbook
Dim ws As Worksheet
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim objAppointment As Outlook.AppointmentItem
Dim strSubject As String
Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
Set oItems = objFolder.Items
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Section 74")
r = ws.Cells(Rows.Count, 1).End(xlUp).Row 'Rows.Count should also have a reference to a wb & ws
For i = 2 To r
If ws.Cells(i, 9) = "N/A" Then
ws.Cells(i, 13) = "Yes"
Set objAppointment = oItems.Item(i)
With objAppointment
If .Subject = strSubject Then
objAppointment.Delete
End If
End With
End If
Next i
End Sub
A With, If and For statement (and more) should always be closed
Sub DeleteCalendarItems()
Dim wb As Workbook
Dim ws As Worksheet
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim objAppointment As Outlook.AppointmentItem
Dim strSubject As String
Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
Set oItems = objFolder.Items
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Section 74")
r = ES.Cells(Rows.Count, 1).End(xlUp).Row 'Rows.Count should also have a reference to a wb & ws
For i = 2 To r
If ES.Cells(i, 9).Value = "N/A" Then
Set objAppointment = oItems.Item(i)
With objAppointment
If .Subject = strSubject Then
objAppointment.Delete
End If
End With
End If
Next i
End Sub
I've managed to work it out (somehow) - I needed to add a nested For loop
Sub DeleteNASec74()
Dim i As Long, j As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim objAppointment As Outlook.AppointmentItem
Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
Set oItems = objFolder.Items
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Section 74")
r = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To r
For j = oItems.Count To 1 Step -1
If ws.Cells(i, 9).Value = "N/A" Then
ws.Cells(i, 13) = "Yes"
Set objAppointment = oItems.Item(j)
With objAppointment
If .Subject = "Send reminder email - " + ws.Cells(i, 2).Value Then
objAppointment.Delete
End If
End With
End If
Next j
Next i
End Sub
Here is the code :
Another problem is if that specific sender has replied to a mail which contains tables that is also copies in the same mail
Sub ImportToExcel()
Dim OutlookApp As Outlook.Application
Dim OutlookNameSpace As Namespace
Dim folder As MAPIfolder
Dim xDoc As Word.Document
Dim xTable As Word.Table
Dim OutlookMail As Variant
Dim xWb As Workbook
Dim xWs As Worksheet
Dim xExcel As Excel.Application
Dim xRow As Integer
Dim i As Integer
Set OutlookApp = New Outlook.Application
Set OutlookNameSpace = OutlookApp.GetNamespace("MAPI")
Set folder=OutlookNameSpace.GetDefaultFolder(olFolderInbox).Folders("DL")
Set xExcel = New Excel.Application
Set xWb = xExcel.Workbooks.Add
xExcel.Visible = True
Set xWs = xWb.Sheets(1)
xRow = 1
For Each OutlookMail In folder.Items
If OutlookMail.ReceivedTime = "1/12/2019" And OutlookMail.Sender = "Vince Onal" Then
Set xDoc = OutlookMail.GetInspector.WordEditor
For i = 1 To xDoc.tables.Count
Set xTable = xDoc.tables(i)
xTable.Range.Copy
xWs.Paste
xRow = xRow + xTable.Rows.Count + 1
xWs.Range("A" & CStr(xRow)).Select
Next
End If
Next
End Sub
To get your format for ReceivedTime:
Debug.Print " OutlookObj.ReceivedTime: " & OutlookObj.ReceivedTime
You will find there cannot be a match with "1/12/2019"
Try
If Format(OutlookMail.ReceivedTime, "mm/dd/yyyy") = "1/12/2019" Then
I am writing a macro in excel to export outlook emails to excel. The code works fine but the date format of 'Flag Completed Date' field changes when the data is exported to excel.
In outlook the format is "dd-mm-yyyy hh:mm" (Example: 21 January 2015 12:42).
When the emails are exported to excel, the format of this field changes to 21 January 2015 00:00
There are other date fields, their formats are correctly showing up in excel. Only this field is having the format issue.
Please help!
Thank you!
KSP
Here is the code that I am using:
Sub InboxToExcel()
Dim objOL As Outlook.Application
Dim objNS As Outlook.Namespace
Dim objInbox As Outlook.Folder
Dim objTable As Outlook.Table
Dim objRow As Outlook.Row
Dim objMsg As Outlook.MailItem
Dim objWB As Excel.Workbook
Dim objWS As Excel.Worksheet
Dim objRange As Excel.Range
Dim strFind As String
Dim strProps As String
Dim arr() As String
Dim val As Variant
Dim i As Integer
Dim intRow As Integer
strProps = _
"SenderName,To,Subject,SentOn,ReadReceiptRequested"
Set objOL = Application
Set objNS = objOL.Session
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objTable = objInbox.GetTable
Set objWB = GetExcelWB()
Set objWS = objWB.Sheets(1)
objWS.Name = "Inbox"
arr = Split(strProps, ",")
intRow = 1
For i = 0 To UBound(arr)
objWS.Cells(intRow, i + 1) = arr(i)
objTable.Columns.Add arr(i)
Next
Set objRange = objWS.Range _
(objWS.Cells(1, 1), objWS.Cells(1, i + 1))
objRange.Font.Bold = True
Do Until objTable.EndOfTable
intRow = intRow + 1
Set objRow = objTable.GetNextRow
For i = 0 To UBound(arr)
val = objRow(arr(i))
Select Case VarType(val)
Case vbDate
val = DateToExcel(val)
Case vbBoolean
val = YesNoToString(val)
End Select
objWS.Cells(intRow, i + 1) = val
Next
Loop
For i = 1 To (UBound(arr) + 1)
objWS.Columns(i).EntireColumn.AutoFit
Next
objWS.Application.Visible = True
objWS.Activate
Set objOL = Nothing
Set objNS = Nothing
Set objRow = Nothing
Set objWB = Nothing
Set objWS = Nothing
Set objRange = Nothing
End Sub
Function DateToExcel(propVal)
Dim dteDate 'As Date
If IsDate(propVal) Then
dteDate = CDate(propVal)
If dteDate = #1/1/4501# Then
DateToExcel = Null
Else
DateToExcel = dteDate
End If
End If
End Function
Function YesNoToString(propVal)
If propVal = "True" Then
YesNoToString = "Yes"
Else
YesNoToString = "No"
End If
End Function
I am exporting Outlook emails in custom table view to Excel. There are custom formula fields in the custom view. All the custom fields export except the formula field.
This is the formula field:
'AssignedDate' formula field: IIf([RequestAssigned]=True,Now(),"")
'RequestAssigned' is a checkbox field, when checked AssignedDate field will capture the date and time when it is checked.
I get a run-time error message-
Run-time error '-2147024809(8070057)':
could not complete the operation. One or more parameter values are not valid
If I remove that formula field the macro works.
Sub InboxToExcel()
Dim objOL As Outlook.Application
Dim objNS As Outlook.Namespace
Dim objInbox As Outlook.Folder
Dim objTable As Outlook.Table
Dim objRow As Outlook.Row
Dim objMsg As Outlook.MailItem
Dim objWB As Excel.Workbook
Dim objWS As Excel.Worksheet
Dim objRange As Excel.Range
Dim strFind As String
Dim strProps As String
Dim arr() As String
Dim val As Variant
Dim i As Integer
Dim intRow As Integer
strProps = _
"SenderName,To,Subject,SentOn,ReadReceiptRequested"
Set objOL = Application
Set objNS = objOL.Session
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objTable = objInbox.GetTable
Set objWB = GetExcelWB()
Set objWS = objWB.Sheets(1)
objWS.Name = "Inbox"
arr = Split(strProps, ",")
intRow = 1
For i = 0 To UBound(arr)
objWS.Cells(intRow, i + 1) = arr(i)
objTable.Columns.Add arr(i)
Next
Set objRange = objWS.Range _
(objWS.Cells(1, 1), objWS.Cells(1, i + 1))
objRange.Font.Bold = True
Do Until objTable.EndOfTable 'POINTING HERE WHILE DEBUGGING
intRow = intRow + 1
Set objRow = objTable.GetNextRow
For i = 0 To UBound(arr)
val = objRow(arr(i))
objWS.Cells(intRow, i + 1) = val
Next
Loop
For i = 1 To (UBound(arr) + 1)
objWS.Columns(i).EntireColumn.AutoFit
Next
objWS.Application.Visible = True
objWS.Activate
Set objOL = Nothing
Set objNS = Nothing
Set objRow = Nothing
Set objWB = Nothing
Set objWS = Nothing
Set objRange = Nothing
End Sub
You cannot check the value of a checkbox directly in a formula. The following link shows you how to set a surrogate cell to store the answer.
http://blog.contextures.com/archives/2013/07/09/use-check-box-result-in-excel-formula/