Reference a workbook when running Excel VBA code within Outlook instead

40 viewsexceloutlookvba
0

The code below works when it is run within the destination Excel workbook.

I want to run the macro from within Outlook.

When I try to add the path to the destination file, it says the subscript is out of range:

    Dim DestFile as Object 
    Set DestFile = Workbooks("T:3-Lending Systems AnalystCollections Master Workbook.xlsm")

Is it because it’s on an external drive?
Do I need to activate the ExcelApp first and/or Open the Workbook?

Option Explicit

Sub ExtractDataFromOutlookEmail()
    
    ' Late binding. Outlook variables declared as Object.
    Dim OutlookApp As Object
    Dim OutlookNamespace As Object
    Dim OutlookFolder As Object
    Dim OutlookItem As Object
    Dim Attachment As Object
    
    Dim ExcelWorkbook As Workbook
    Dim ExcelWorksheet As Worksheet
    
    Dim TempFilePath As String
    
    Dim RangeToExtract As Range
    Dim RangeToCopy As Range
    
    ' Set the path where you want to save the extracted data
    TempFilePath = Environ$("temp")
    
      ******' Set the range where you want to paste the extracted data
    Set DestFile = T:3-Lending Systems AnalystCollections Master Workbook TESTING.xlsm
    Set RangeToExtract = DestFile.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1) ' Change to your desired range******
    
    ' Create a new Outlook application
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    
    ' Specify the Outlook folder where the email is located
    Set OutlookFolder = OutlookNamespace.GetDefaultFolder(6).Folders("Projects").Folders("Collections").Folders("Daily Reports") ' Change to the appropriate folder
    
    Application.ScreenUpdating = False
    
    ' Loop through the emails in the folder
    For Each OutlookItem In OutlookFolder.Items
    
        'Debug.Print OutlookItem.Subject
        
        If TypeName(OutlookItem) = "MailItem" Then
        
            ' Check if the email has the desired attachments
            If OutlookItem.Attachments.Count >= 1 Then
                
                ' Check if the attachments have specific titles
                Dim AttachmentTitles(1 To 3) As String
                AttachmentTitles(1) = "Queue Status - Collections.csv" ' Replace with the title of the first attachment
                AttachmentTitles(2) = "KPI Collections - Inbound.csv" ' Replace with the title of the second attachment
                AttachmentTitles(3) = "KPI Collections - Outbound.csv" ' Replace with the title of the third attachment
                
                Dim AttachmentCount As Long
                AttachmentCount = 0
                
                ' Loop through the attachments in the email
                For Each Attachment In OutlookItem.Attachments
                    If Attachment.Filename = AttachmentTitles(1) Then
                        
                        ' Save the attachment to the temporary location
                        Attachment.SaveAsFile TempFilePath & AttachmentTitles(1)
                        
                        ' Open the saved Excel attachment
                        Set ExcelWorkbook = Workbooks.Open(TempFilePath & AttachmentTitles(1))
                        
                        ' Copy the data from the Excel attachment
                        Set RangeToCopy = ExcelWorkbook.Sheets(1).Range("A2:S12") ' Assuming data is in the first sheet
                        
                        RangeToCopy.Copy Destination:=RangeToExtract.Offset ' Offset to paste data in different columns
                        
                        ' Close the Excel attachment
                        ExcelWorkbook.Close SaveChanges:=False
                        
                        ' Clean up Excel objects
                        Set ExcelWorksheet = Nothing
                        Set ExcelWorkbook = Nothing
                        
                        ' Increment the attachment count
                        AttachmentCount = AttachmentCount + 1
                        
                        ' Exit the loop if all three attachments are processed
                        If AttachmentCount >= 3 Then Exit For
                            
                    End If
                Next Attachment
                
                For Each Attachment In OutlookItem.Attachments
                
                    If Attachment.Filename = AttachmentTitles(2) Then
                        
                        ' Save the attachment to the temporary location
                        Attachment.SaveAsFile TempFilePath & AttachmentTitles(2)
                        
                        ' Open the saved Excel attachment
                        Set ExcelWorkbook = Workbooks.Open(TempFilePath & AttachmentTitles(2))
                        
                        ' Copy the data from the Excel attachment
                        Set RangeToCopy = ExcelWorkbook.Sheets(1).Range("H2:X12") ' Assuming data is in the first sheet
                        
                        RangeToCopy.Copy Destination:=RangeToExtract.Offset(, 19) ' Offset to paste data in different columns
                        
                        ' Close the Excel attachment
                        ExcelWorkbook.Close SaveChanges:=False
                        
                        ' Clean up Excel objects
                        Set ExcelWorksheet = Nothing
                        Set ExcelWorkbook = Nothing
                        
                        ' Increment the attachment count
                        AttachmentCount = AttachmentCount + 1
                        
                        ' Exit the loop if all three attachments are processed
                        If AttachmentCount >= 3 Then Exit For
                            
                    End If
                Next Attachment
                
                For Each Attachment In OutlookItem.Attachments
                
                    If Attachment.Filename = AttachmentTitles(3) Then
                        
                        ' Save the attachment to the temporary location
                        Attachment.SaveAsFile TempFilePath & AttachmentTitles(3)
                        
                        ' Open the saved Excel attachment
                        Set ExcelWorkbook = Workbooks.Open(TempFilePath & AttachmentTitles(3))
                        
                        ' Copy the data from the Excel attachment
                        Set RangeToCopy = ExcelWorkbook.Sheets(1).Range("H2:X12") ' Assuming data is in the first sheet
                        
                        RangeToCopy.Copy Destination:=RangeToExtract.Offset(, 36) ' Offset to paste data in different columns
                        
                        ' Close the Excel attachment
                        ExcelWorkbook.Close SaveChanges:=False
                            
                        ' Clean up Excel objects
                        Set ExcelWorksheet = Nothing
                        Set ExcelWorkbook = Nothing
                         
                        ' Increment the attachment count
                        AttachmentCount = AttachmentCount + 1
                            
                        ' Exit the loop if all three attachments are processed
                        If AttachmentCount >= 3 Then Exit For
                            
                    End If
                Next Attachment
            End If
        End If
    Next OutlookItem
    
    ' Clean up Outlook objects
    Set OutlookItem = Nothing
    Set OutlookFolder = Nothing
    Set OutlookNamespace = Nothing
    Set OutlookApp = Nothing
    
    ' Delete the temporary Excel files
    If Dir(TempFilePath & AttachmentTitles(1)) <> "" Then
        Kill TempFilePath & AttachmentTitles(1)
    End If
    
    If Dir(TempFilePath & AttachmentTitles(2)) <> "" Then
        Kill TempFilePath & AttachmentTitles(2)
    End If
        
    If Dir(TempFilePath & AttachmentTitles(3)) <> "" Then
        Kill TempFilePath & AttachmentTitles(3)
    End If
    
    Application.ScreenUpdating = True
    ThisWorkbook.Save
    ThisWorkbook.Close
    ExcelApp.Quit

End Sub