Your code works fine - however
1. You keep losing spaces in statements that you have posted
2. The paths need to be terminated with a backslash character or they become part of the filename.
3. The paths must exist, so I have added code to create them when missing.
4. The string to search for must be EXACTLY as entered in the filename and not some variation of it. For mixed case you would need e.g.
If InStr(1, LCase(oAttachment.fileName), LCase(strText1)) > 0 Then
Option Explicit
Sub RunTest()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
Test olMsg
lbl_Exit:
Exit Sub
End Sub
Public Sub Test(mItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim lngFldr As Long
Const sSaveFolder1 As String = "C:\Test1\"
Const sSaveFolder2 As String = "C:\Test2\"
Const sSaveFolder3 As String = "C:\Test3\"
Const sSaveFolder4 As String = "C:\Test4\"
Const sSaveFolder5 As String = "C:\Test5\"
Const sSaveFolder6 As String = "C:\Test6\"
Const sSaveFolder7 As String = "C:\Test7\"
Const sSaveFolder8 As String = "C:\Test8\"
Const sSaveFolder9 As String = "C:\Test9\"
Const sSaveFolder10 As String = "C:\Test10\"
Const strText1 As String = "Test String 1"
Const strText2 As String = "Test String 2"
Const strText3 As String = "Test String 3"
Const strText4 As String = "Test String 4"
Const strText5 As String = "Test String 5"
Const strText6 As String = "Test String 6"
Const strText7 As String = "Test String 7"
Const strText8 As String = "Test String 8"
Const strText9 As String = "Test String 9"
Const strText10 As String = "Test String 10"
For lngFldr = 1 To 10
CreateFolders "C:\Test" & lngFldr & "\"
Next lngFldr
For Each oAttachment In mItem.Attachments
If InStr(1, oAttachment.fileName, strText1) > 0 Then
oAttachment.SaveAsFile sSaveFolder1 & oAttachment.fileName
End If
If InStr(1, oAttachment.fileName, strText2) > 0 Then
oAttachment.SaveAsFile sSaveFolder2 & oAttachment.fileName
End If
If InStr(1, oAttachment.fileName, strText3) > 0 Then
oAttachment.SaveAsFile sSaveFolder3 & oAttachment.fileName
End If
If InStr(1, oAttachment.fileName, strText4) > 0 Then
oAttachment.SaveAsFile sSaveFolder4 & oAttachment.fileName
End If
If InStr(1, oAttachment.fileName, strText5) > 0 Then
oAttachment.SaveAsFile sSaveFolder5 & oAttachment.fileName
End If
If InStr(1, oAttachment.fileName, strText6) > 0 Then
oAttachment.SaveAsFile sSaveFolder6 & oAttachment.fileName
End If
If InStr(1, oAttachment.fileName, strText7) > 0 Then
oAttachment.SaveAsFile sSaveFolder7 & oAttachment.fileName
End If
If InStr(1, oAttachment.fileName, strText8) > 0 Then
oAttachment.SaveAsFile sSaveFolder8 & oAttachment.fileName
End If
If InStr(1, oAttachment.fileName, strText9) > 0 Then
oAttachment.SaveAsFile sSaveFolder9 & oAttachment.fileName
End If
If InStr(1, oAttachment.fileName, strText10) > 0 Then
oAttachment.SaveAsFile sSaveFolder10 & oAttachment.fileName
End If
Next oAttachment
Set oAttachment = Nothing
End Sub
Private Function CreateFolders(strPath As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 31 May 2017
'Creates the full path 'strPath' if missing or incomplete
Dim strTempPath As String
Dim lngPath As Long
Dim VPath As Variant
Dim oFSO As Object
Dim i As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
VPath = Split(strPath, "\")
If Left(strPath, 2) = "\\" Then
strPath = "\\" & VPath(2) & "\"
For lngPath = 3 To UBound(VPath)
strPath = strPath & VPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
Else
strPath = VPath(0) & "\"
For lngPath = 1 To UBound(VPath)
strPath = strPath & VPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
End If
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function