An automated way to save xlsx attachments through outlook

Sub SaveAttachments()

    Dim olApp As Outlook.Application
    Dim olNs As NameSpace
    Dim Fldr As MAPIFolder
    Dim MoveToFldr As MAPIFolder
    Dim olMi As MailItem
    Dim olAtt As Attachment
    Dim MyPath As String
    Dim i As Long

    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
    Set MoveToFldr = Fldr.Folders("CompSurv")
    MyPath = "C:\My Documents\Completed Survey\"

    For i = Fldr.Items.Count To 1 Step -1
        Set olMi = Fldr.Items(i)
        If InStr(1, olMi.Subject, "Completed Survey") > 0 Then
            For Each olAtt In olMi.Attachments
                If olAtt.FileName = "Test.xls" Then
                    olAtt.SaveAsFile MyPath & olMi.SenderName & ".xls"
                End If
            Next olAtt
            olMi.Save
            olMi.Move MoveToFldr
        End If
    Next i

    Set olAtt = Nothing
    Set olMi = Nothing
    Set Fldr = Nothing
    Set MoveToFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing

End Sub