Count Emails in a Shared Mailbox by date and Export to Excel.

[sudoreaper]

Hey guys!

New to this forum, and trying to slap together a project to make my mornings a bit easier.

I'm looking to count all of the email in a folder and all of its subfolders, and give me a count of each date in the folder. As of now, I have them exporting to excel and giving me a count, but it does not break the count down by date. Ideally, I would like to exclude any emails with today's date from the counts, as emails that come in are not assigned until the next day, and then for each folder have a column that displays the oldest date in that folder/subfolder.

I would even take this data as a messagebox though excel is prefered.

Any help anyone could provide would be very appreciated.

Here is the code I'm working with:

Sub Morning_Counts()
Dim xSourceFolder As Outlook.Folder, xSubFolder As Outlook.Folder
Dim xFilePath As String
Dim xExcelApp As Excel.Application
Dim xWb As Excel.Workbook
Dim xWs As Excel.Worksheet
On Error Resume Next
Set xExcelApp = New Excel.Application
Set xWb = xExcelApp.Workbooks.Add
Set xWs = xWb.Sheets(1)
xWs.Cells(1, 1) = "Folder"
xWs.Cells(1, 2) = "Count Items"
xWs.Cells(1, 3) = "Last Count"
xWs.Cells(1, 4) = "Analyst"
xWs.Cells(2, 4) = "Chris Stein"
xWs.Cells(2, 3) = Format(Now, "mm/dd/yyyy HH:mm:ss")
Set xSourceFolder = Outlook.Application.Session.PickFolder
If xSourceFolder = nill Then
xWb.Close False
xExcelApp.Quit
Exit Sub
End If
For Each xSubFolder In xSourceFolder.Folders
Call ProcessFolders(xWs, xSubFolder)
Next
xWs.Columns("A:B").AutoFit
Set xShell = CreateObject("Shell.Application")
Set xFolder = xShell.BrowseForFolder(0, "Select a Folder:", 0, 0)
If TypeName(xFolder) = "Nothing" Then
xWb.Close False
xExcelApp.Quit
Exit Sub
End If
Set xFolderItem = xFolder.self
xFilePath = xFolderItem.Path & "\"
xFilePath = xFilePath & "Morning Counts.xlsx"
xWb.Close True, xFilePath
xExcelApp.Quit
Set xShell = Nothing
MsgBox "Morning Counts have been updated. Please refresh the report.", vbExclamation, "Operations"
End Sub
Sub ProcessFolders(ByVal Ws As Worksheet, ByVal xCurFolder As Outlook.Folder)
Dim xSubFld As Folder
Dim xItemCount As Long
Dim xRow As Integer
xItemCount = xCurFolder.Items.Count
xRow = Ws.UsedRange.Rows.ReceivedTime.Count + 1
Ws.Cells(xRow, 1) = xCurFolder.FolderPath
Ws.Cells(xRow, 2) = xItemCount
If xCurFolder.Folders.Count > 0 Then
For Each xSubFld In xCurFolder.Folders
Call ProcessFolders(Ws, xSubFld)
Next
End If
End Sub

 

[Lars1]

Hey guys!

New to this forum, and trying to slap together a project to make my mornings a bit easier.

I'm looking to count all of the email in a folder and all of its subfolders, and give me a count of each date in the folder. As of now, I have them exporting to excel and giving me a count, but it does not break the count down by date. Ideally, I would like to exclude any emails with today's date from the counts, as emails that come in are not assigned until the next day, and then for each folder have a column that displays the oldest date in that folder/subfolder.

I would even take this data as a messagebox though excel is prefered.

Any help anyone could provide would be very appreciated.

Here is the code I'm working with:

Sub Morning_Counts()
Dim xSourceFolder As Outlook.Folder, xSubFolder As Outlook.Folder
Dim xFilePath As String
Dim xExcelApp As Excel.Application
Dim xWb As Excel.Workbook
Dim xWs As Excel.Worksheet
On Error Resume Next
Set xExcelApp = New Excel.Application
Set xWb = xExcelApp.Workbooks.Add
Set xWs = xWb.Sheets(1)
xWs.Cells(1, 1) = "Folder"
xWs.Cells(1, 2) = "Count Items"
xWs.Cells(1, 3) = "Last Count"
xWs.Cells(1, 4) = "Analyst"
xWs.Cells(2, 4) = "Chris Stein"
xWs.Cells(2, 3) = Format(Now, "mm/dd/yyyy HH:mm:ss")
Set xSourceFolder = Outlook.Application.Session.PickFolder
If xSourceFolder = nill Then
xWb.Close False
xExcelApp.Quit
Exit Sub
End If
For Each xSubFolder In xSourceFolder.Folders
Call ProcessFolders(xWs, xSubFolder)
Next
xWs.Columns("A:B").AutoFit
Set xShell = CreateObject("Shell.Application")
Set xFolder = xShell.BrowseForFolder(0, "Select a Folder:", 0, 0)
If TypeName(xFolder) = "Nothing" Then
xWb.Close False
xExcelApp.Quit
Exit Sub
End If
Set xFolderItem = xFolder.self
xFilePath = xFolderItem.Path & "\"
xFilePath = xFilePath & "Morning Counts.xlsx"
xWb.Close True, xFilePath
xExcelApp.Quit
Set xShell = Nothing
MsgBox "Morning Counts have been updated. Please refresh the report.", vbExclamation, "Operations"
End Sub
Sub ProcessFolders(ByVal Ws As Worksheet, ByVal xCurFolder As Outlook.Folder)
Dim xSubFld As Folder
Dim xItemCount As Long
Dim xRow As Integer
xItemCount = xCurFolder.Items.Count
xRow = Ws.UsedRange.Rows.ReceivedTime.Count + 1
Ws.Cells(xRow, 1) = xCurFolder.FolderPath
Ws.Cells(xRow, 2) = xItemCount
If xCurFolder.Folders.Count > 0 Then
For Each xSubFld In xCurFolder.Folders
Call ProcessFolders(Ws, xSubFld)
Next
End If
End Sub

Hi

I am really new to this VBA, but it looks like what you are doing here is exactly what i am looking for.
unfortunately i can´t help you with your question, but hopefully you can help me

This VBA, is this running fro Outlook or is it running from Excel ?
Either way i am getting an error...

BR. Lars