Macro to Import Information from Email Attachments into excel

Frequent Contributor



I receive an email each day from a PDF and excel file which i then convert into another file. Essentially i remove some information and then issue as a CSV file.


As this occurs daily, i am hoping to automate the process. I have done some research online and found some macros such as below. I am hoping someone can assist in updating to match my template so i import the correct attachment. In order to identify this i am hoping to use the emails "Subject Header" and name of each attachment to populate into excel as required.


Sub CopyAttachmentToExcel(olitem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlTempWB As Object
Dim xlSheet As Object
Dim xlTempSheet As Object
Dim lngTempLast As Integer
Dim lngLast As Integer
Dim strFname As String
Dim strTempPath As String
Dim bXLStarted As Boolean

Const strPath As String = "D:\My Documents\Collate.xlsx" 'the path and name of the local workbook
strTempPath = Left(strPath, InStrRev(strPath, "\")) 'The path of the temporary file

On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
bXLStarted = True
End If
xlApp.Visible = True

On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1") 'The sheet in the local workbook

'Process the message attachment
With olitem.Attachments.Item(1)
If Right(.DisplayName, 4) = "xlsx" Then
lngLast = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
strFname = strTempPath & .DisplayName
.SaveAsFile strFname
Set xlTempWB = xlApp.Workbooks.Open(strFname, editable:=True)
Set xlTempSheet = xlTempWB.Sheets("DATA")
lngTempLast = xlTempSheet.Range("B" & xlTempSheet.Rows.Count).End(-4162).Row
xlSheet.Range("A" & lngLast + 1, "S" & lngLast + lngTempLast - 1).Value = xlTempSheet.Range("A2", "S" & lngTempLast).Value
End If

End With
xlWB.Close SaveChanges:=True
xlTempWB.Close SaveChanges:=False
If bXLStarted Then
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set xlTempWB = Nothing
Set xlTempSheet = Nothing
Set olitem = Nothing
End Sub


Can someone please assist.


Many thanks,

0 Replies