Excel - ENVIAR CORREOS CON ADJUNTOS Y EVALUANDO EL NOMBRE DEL ARCHIVO DESDE VBA EXCEL

Sub Send_Multiple_Email()

On Error GoTo ETIQ

Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("Hoja1")

Dim OA As Object

Dim rut, myFile As String

Dim myColection As New Collection

Dim x As Integer

Dim n As Integer

Dim msg As Object

Set OA = CreateObject("OutLook.Application")

Dim i As Integer

Dim last_row As Integer

Dim P As String

rut = "AQUI VA LA RUTA"

P = Firmas

last_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row

For i = 8 To last_row

myFile = Dir(rut & sh.Range("c" & i).Value2 & "\*.*")

Do Until myFile = ""

myColection.Add myFile

myFile = Dir()

Msgbox my File   'EN ESTA LÍNEA DE CODIGO COMPROBE QUE HABIA UN ARCHIVO NO ME LO ALMACENADA QUIZAS POR ESO EN EL GOTO ME DICE QUE EL ARCHIVO NO EXISTE AÚN EXISTIENDO.

Loop

Set msg = OA.CreateItem(0)

    'PARA

    msg.To = sh.Range("h" & i).Value2

    'COPIA

    msg.CC = "tt@tommy.com.do"

    'ASUNTO

    msg.Subject = sh.Range("c" & i).Value2

    'CUERPO

    msg.HTMLBody = "Adjunto lo solicitado"

'    ADJUNTOS

    If sh.Range("j" & i).Value2 = "SOL DE INSP" And sh.Range("l" & i).Value2 = "OBRA" Then

        For n = 1 To myColection.Count

    'AQUI EVALUO LA NOMENCLATURA        'EN LA COLUMAN "M" VARIA EL NUMERO O ES UNO O DOS O MAS

    If Left(myColection(n), 3) = "SS" & Left(sh.Range("m" & i).Value2, 1) Then

        msg.attachments.Add rut & sh.Range("c" & i).Value2 & "\" & myColection(n)

    End If

     Next n

    End If

    msg.Display

    Next i

ETIQ:

If Err.Number = -2147024894 Or Err.Number = -2147024893 Then

MsgBox "EL ARCHIVO NO EXISTE"

End If

End Sub