copy data from outlook attached excel file into a local one

[s_samira_21]

Hi

I get some emails each day with an Excel workbook attached that contains data on its first worksheet. I copy and paste data into my local workbook. Is there a way to have VBA in outlook that after receiving email, open the attachment, copy the data and past it into the local workbook and close the attachment?



thanks

regards

[gmayor]

That would be fairly straightforward. You would need to set an Outlook rule to identify the incoming messages and run a script from that rule. The script would save then open the attachment in Excel, then open the target workbook and do whatever processing you require before closing the attachment and optionally deleting it from the filing system. Something like the following:

Sub ProcessAttachment(Item As Outlook.MailItem)
Dim olAtt As Attachment
Dim strFilename As String
Dim xlApp As Object
Dim xlWB As Object
Dim xlTarget As Object
Const strTarget As String = "C:\Path\TargetBookName.xlsx"
    If Item.Attachments.Count > 0 Then
        For Each olAtt In Item.Attachments
            If Right(olAtt.Filename, 4) = "xlsx" Then
                strFilename = "C:\Path\" & olAtt.Filename
                olAtt.SaveAsFile strFilename
                Set xlApp = GetObject(, "Excel.Application")
                If Err <> 0 Then
                    Set xlApp = CreateObject("Excel.Application")
                End If
                On Error GoTo 0
                Set xlWB = xlApp.workbooks.Open(strFilename)
                Set xlTarget = xlApp.workbooks.Open(strTarget)
                '+++++++++++++++++++++++++++++
                'Do stuff with the 2 workbooks
                '+++++++++++++++++++++++++++++
                xlWB.Close 0        'Close attachment without saving
                'Kill strFilename 'Optional delete the saved attachment
                Set xlWB = Nothing
                Set xlTarget = Nothing
                Set xlApp = Nothing
                Exit For
            End If
        Next olAtt
    End If
End Sub

[s_samira_21]

Thanks

I will test and tell you what happens.

But Where should I paste this code? ThisOutlookSession or a Module?

[s_samira_21]

I wrote this code base on my googling data, in thisOutlookSession.
this code is like the one you kindly wrote for me.
But when I receive a new mail, nothing happens

Option Explicit
Dim WithEvents OLInboxItems As Items

Private Sub Application_Startup()

Dim OLNS As Outlook.NameSpace

Set OLNS = Application.GetNamespace("MAPI")
Set OLInboxItems = OLNS.GetDefaultFolder(olFolderInbox).Items

End Sub

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)

'On Error Resume Next

Dim OLMailItem As MailItem
Dim AttPath, AttName

If TypeOf Item Is MailItem Then
Set OLMailItem = Item

'--------------------------
If OLMailItem.Attachments.Count > 0 _
And OLMailItem.Subject = "AHOrdUpdate" Then

AttName = OLMailItem.Attachments.Item(1).FileName
AttPath = "G:\Projects\Excel\TAC\TAC Data Management\Orders\AHOrders\Updates\updates\" + AttName
OLMailItem.Attachments.Item(1).SaveAsFile AttPath

End If
'---------------------

Dim xlApp, AttWB, UpdateWB, AttWS, UpdateWS As Object
Dim rng As Range
Dim AttEOC, AttEOR, EOC As Integer


'-----------------------
Set xlApp = CreateObject("Excel.Application")

With xlApp
.Visible = True
.EnableEvents = False
End With

Set AttWB = Workbooks.Open(AttPath, , False, , , , , , , True)
AttWB.Activate
Set AttWS = AttWB.sheets("sheet1")

With AttWS
Set AttEOC = Application.WorksheetFunction.CountA("A:A")
Set AttEOR = Application.WorksheetFunction.CountA("1:1")
Set rng = .Range("A1:" & AttEOR & AttEOC)
rng.Copy
.Close Save:=False
End With


'-------------------------------


'----------------------------
Set UpdateWB = Workbooks.Open("G:\Projects\Excel\TAC\TAC Data Management\Orders\AHOrders\Updates\updates.xlsx", , False, , , , , , , True)
UpdateWB.Activate
Set UpdateWS = UpdateWB.sheets("sheet1")

With UpdateWS
Set EOC = .cells(Rows.Count, "A").End(xlUp).Row
.cells(EOC, "A").Paste
.Close Save:=True

End With

'-----------------------------------------------

End If
Set Item = Nothing
Set OLMailItem = Nothing

End Sub

[gmayor]

Originally Posted by s_samira_21

But Where should I paste this code? ThisOutlookSession or a Module?

The code goes in an ordinary module.
You can test it by selecting a message and running the following:

Sub Test()
Dim olMsg As MailItem
Set olMsg = ActiveExplorer.Selection.Item(1)
ProcessAttachment olMsg
End Sub

Note that you will have to change the paths and the filename of your target workbook, and of course add the code to transfer whatever it is that you wish to transfer from one sheet to the other.