Renombrar archivos xml y enviar por email desde excel

H o l a:

Te anexo la macro, solamente queda un detalle, en el asunto estoy poniendo el texto:

Dirigido a:     y    Pago a:

Dime si es correcto o pon un ejemplo de lo que debe estar en el asunto, ya que el destinatario lo estoy tomando de la columna F.

Sub RenombrarEnviar()
'Por.Dante Amor
    Columns("H").Clear
    ruta = ThisWorkbook.Path & "\"
    For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
        arch1 = Cells(i, "A")
        arch2 = Cells(i, "C") & " " & Format(Cells(i, "D"), "mmmm yyyy") & ".XML"
        If Dir(ruta & arch1) <> "" Then
            FileCopy ruta & arch1, ruta & arch2
            Set dam = CreateObject("outlook.application").createitem(0)
            dam.To = Cells(i, "F")
            dam.Subject = "Dirigido a : " & Cells(i, "B") & " . Pago a: " & Cells(i, "C") & Format(Cells(i, "D"), "mmmm yyyy")
            dam.body = "Pago correspondiente a " & Format(Cells(i, "D"), "mmmm yyyy") & " por " & Format(Cells(i, "E"), "$#,##0.00")
            dam.Attachments.Add ruta & arch2
            dam.send 'El correo se envía en automático
            'dam.display 'El correo se muestra
            Cells(i, "H") = "Enviado"
        Else
            Cells(i, "H") = "no existe el archivo"
        End If
    Next
    MsgBox "Fin"
End Sub

':)
':)