Need to consolidate outlook basic details and excel attachment field details

[rahulsmile]

We receive 3000+ emails monthly with attached Excel workbooks. We copy email details and data from attached Excel files to a master file.

Each email will have one attached Excel file. Ignore attached pdf notepad files.

I am using multiple shared email boxes so that user can pick whichever shared email box and folder as well..

Outlook details can be copied to master data with below code.

How do I copy data in the attachment fileds to my master Excel file? ( save the attachment if helpful here )

Much appreciated for your help to resolve below issue

Option Explicit

Sub GetMailInfo()
Dim results() As String
' get contacts
results = ExportEmails(True)
' paste onto worksheet
Range(Cells(1, 1),
Cells(UBound(results),
UBound(results, 2))).Value
= results

MsgBox "Completed"
End Sub


Function ExportEmails(Optional
headerRow As Boolean = False) As
String()

Dim objOutlook As Object '
Outlook.Application
Dim objNamespace As Object '
Outlook.Namespace
Dim strFolderName As Object
Dim objMailbox As Object
Dim objFolder As Object
Dim mailFolderItems As Object '
Outlook.items
Dim folderItem As Object
Dim msg As Object ' Outlook.MailItem
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long ' counter for
attachments
Dim debugMsg As Integer

' select output results worksheet and
clear previous results
Sheets("Outlook Results").Select
Sheets("Outlook
Results").Cells.ClearContents
Range("A1").Select

Set objOutlook =
CreateObject("Outlook.Application")
'MsgBox objOutlook, vbOKOnly 'for
debugging
Set objNamespace =
objOutlook.GetNamespace("MAPI")
'MsgBox objNamespace, vbOKOnly 'for
debugging
'Set objInbox =
objNamespace.GetDefaultFolder(olFolderInbox)
'MsgBox objInbox, vbOKOnly 'for debugging
Set strFolderName = objNamespace.PickFolder
Set mailFolderItems = strFolderName.Items

' if calling procedure wants header row
If headerRow Then
startRow = 1
Else
startRow = 0
End If

numRows = mailFolderItems.Count
' resize array
ReDim tempString(1 To (numRows + startRow), 1 To 100)
' loop through folder items
For i = 1 To numRows
Set folderItem = mailFolderItems.Item(i)

If IsMail(folderItem) Then
Set msg = folderItem
End If

With msg
tempString(i + startRow, 1) = .ReceivedByName
tempString(i + startRow, 2) = .ReceivedTime
tempString(i + startRow, 3) = .SenderEmailAddress
tempString(i + startRow, 4) = .SenderName
tempString(i + startRow, 5) = .SentOn
tempString(i + startRow, 6) = .Size
tempString(i + startRow, 7) = .Subject
tempString(i + startRow, 8) = .To
End With

' adding file attachment names where they exist - added by JP
If msg.Attachments.Count > 0 Then
For jAttach = 1 To msg.Attachments.Count
tempString(i + startRow, 39 + jAttach) =



msg.Attachments.Item(jAttach).DisplayName
Next jAttach
End If
Next i

' first row of array should be header
values
If headerRow Then
tempString(1, 1) = "ReceivedByName"
tempString(1, 2) = "ReceivedTime"
tempString(1, 3) = "SenderEmailAddress"
tempString(1, 4) = "SenderName"
tempString(1, 5) = "SentOn"
tempString(1, 6) = "size"
tempString(1, 7) = "subject"
tempString(1, 8) = "To"
End If

ExportEmails = tempString

' apply pane freeze and filtering

Range("A2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
'Selection.AutoFilter
End Function


Function IsMail(itm As Object) As
Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function


Column L is only counts of line in attachment excel lines

Could you please help me

Thank you

[arnelgp]

Sub GetMailInfo()
Dim results() As String
' get contacts
results = ExportEmails(True)
' paste onto worksheet
Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results
MsgBox "Completed"
End Sub




Function ExportEmails(Optional headerRow As Boolean = False) As String()


Dim objOutlook As Object 'Outlook.Application
Dim objNamespace As Object 'Outlook.Namespace
Dim strFolderName As Object
Dim objMailbox As Object
Dim objFolder As Object
Dim mailFolderItems As Object 'Outlook.Items
Dim folderItem As Object
Dim msg As Object ' Outlook.MailItem
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long ' counter for Attachments
Dim debugMsg As Integer
'arnelgp
Dim Country, Department, Lines, Typ, Itm1, Itm2
Dim strAttach As String, strPath As String
Dim objAttach As Object

strPath = Environ$("temp") & "\"

' select output results worksheet and clear previous results
Sheets("Outlook Results").Select
Sheets("Outlook results").Cells.ClearContents
Range("A1").Select

Set objOutlook = CreateObject("Outlook.Application")
'MsgBox objOutlook, vbOKOnly 'for debugging
Set objNamespace = objOutlook.GetNamespace("MAPI")
'MsgBox objNamespace, vbOKOnly 'for debugging
'Set objInbox = objNamespace.GetDefaultFolder (olFolderInbox)
'MsgBox objInbox, vbOKOnly 'for debugging
Set strFolderName = objNamespace.PickFolder
Set mailFolderItems = strFolderName.Items

' if calling procedure wants header row
If headerRow Then
startRow = 1
Else
startRow = 0
End If

numRows = mailFolderItems.Count
' resize array
ReDim tempString(1 To (numRows + startRow), 1 To 100)
' loop through folder items
For i = 1 To numRows
Set folderItem = mailFolderItems.Item(i)

If IsMail(folderItem) Then
Set msg = folderItem
End If

With msg
tempString(i + startRow, 1) = .ReceivedByName
tempString(i + startRow, 2) = .ReceivedTime
tempString(i + startRow, 3) = .SenderEmailAddress
tempString(i + startRow, 4) = .SenderName
tempString(i + startRow, 5) = .SentOn
tempString(i + startRow, 6) = .Size
tempString(i + startRow, 7) = .Subject
tempString(i + startRow, 8) = .To
End With

' adding file attachment names where they exist - added by JP
If msg.Attachments.Count > 0 Then
For jAttach = 1 To msg.Attachments.Count
Set objAttach = msg.Attachments.Item(jAttach)
strAttach = msg.Attachments.Item(jAttach).DisplayName
tempString(i + startRow, 39 + jAttach) = strAttach

'arnelgp
If Right$(strAttach, 4) = ".xls" Or _
Right$(strAttach, 5) Like ".xls*" Then

Country = "": Department = "": Lines = 0
Typ = "": Itm1 = "": Itm2 = ""

On Error Resume Next
Kill strPath & strAttach

objAttach.SaveAsFile strPath & strAttach

Call ProcessWB(strPath & strAttach, Country, Department, Lines, Typ, Itm1, Itm2)

Set objAttach = Nothing
tempString(i + startRow, 9) = Country
tempString(i + startRow, 10) = Department
tempString(i + startRow, 11) = Lines
tempString(i + startRow, 12) = Typ
tempString(i + startRow, 13) = Itm1
tempString(i + startRow, 14) = Itm2
End If
Next jAttach
End If
Next i

' first row of array should be header Values
If headerRow Then
tempString(1, 1) = "ReceivedByName"
tempString(1, 2) = "ReceivedTime"
tempString(1, 3) = "SenderEmailAddress"
tempString(1, 4) = "SenderName"
tempString(1, 5) = "SentOn"
tempString(1, 6) = "size"
tempString(1, 7) = "subject"
tempString(1, 8) = "To"
'arnelgp
tempString(1, 9) = "Country"
tempString(1, 10) = "Department"
tempString(1, 11) = "No. of line items count"
tempString(1, 12) = "Type"
tempString(1, 13) = "Item1"
tempString(1, 14) = "Item2"
End If

ExportEmails = tempString

' apply pane freeze and filtering

Range("A2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
'Selection.AutoFilter
End Function




Function IsMail(itm As Object) As Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function


'arnelgp
Public Function ProcessWB(ByVal wbName As String, _
ByRef Country, _
ByRef Dept, _
ByRef Lines, _
ByRef Typ, _
ByRef Itm1, _
ByRef Itm2) As Boolean
Static objExcel As Excel.Application
Dim wb As Workbook, sh As Worksheet
If objExcel Is Nothing Then
Set objExcel = New Excel.Application
End If
Set wb = objExcel.Workbooks.Open(wbName)
Set sh = wb.Sheets(1)
With sh
Country = .Range("A2") & ""
Dept = .Range("B2") & ""
Typ = .Range("D2") & ""
Itm1 = .Range("K2") & ""
Itm2 = .Range("L2") & ""
Lines = .Cells(.Rows.Count, 1).End(xlUp).Row - 3
End With
Set sh = Nothing
wb.Close False
Set wb = Nothing
End Function

[rahulsmile]

Beautiful it is perfectly working fine:clap: .... Thank you so much .... Am impressed by looking perfect code how can I donate you small gift from myside

[rahulsmile]

One additional just for information Count of line from attachment am getting .... In future if I want to add SUM formula how to use I tried but it not picked

[arnelgp]

One additional just for information Count of line from attachment am getting .... In future if I want to add SUM formula how to use I tried but it not picked
can you add it manually upong completion of the VBA?

[rahulsmile]

Not an issue .... I must thankful for your efforts please let me know how can I send some donation

[arnelgp]

i am still new to this forum (see 35 post only).
you should direct your enquiries to the moderators of this forum.

i see on the upper menu, there is paypal donation. click it and see.

[rahulsmile]

:thumb Thank you