Macro para comprobar la existencia de archivos
Estoy usando la macro de Dante Amor para enviar correos masivos con adjuntos distintos. Pero son 112 y hay veces que no existe uno de los archivos adjuntos y la macro, obviamente, se para. He buscado por aquí macros para comprobar primero la existencia de los archivos, pero no he encontrado nada que me permita comprobar todos los ficheros listados en esa columna. Encontré una hace tiempo, que he perdido, pero al ser tantos ficheros, dar intro cada vez que me decía que sí existía el fichero o que no existía el fichero era bastante pesado. En resumen, necesitaría, sobre la base de la macro de Dante
'***Macro Para enviar correos
Sub correo()
'Por.Dante Amor
col = Range("H1").Column
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = Range("B" & i) 'Destinatarios
dam.CC = Range("C" & i) 'Con copia
dam.Bcc = Range("D" & i) 'Con copia oculta
dam.Subject = Range("E" & i) '"Asunto"
dam.body = Range("F" & i) '"Cuerpo del mensaje"
'
For j = col To Cells(i, Columns.Count).End(xlToLeft).Column
archivo = Cells(i, j)
If archivo <> "" Then dam.Attachments.Add archivo
Next
dam.Send 'El correo se envía en automático
'dam.save 'El correo se muestra
Next
MsgBox "Correos enviados", vbInformation, "SALUDOS"
End SubQue antes de esto me dijera qué ficheros faltan de los listados en la columna H, pero que no me dijera los que sí están (dado que son tantos).
2 Respuestas
H o la:
Te anexo la macro actualizada para verificar la existencia del archivo.
Si no existe el archivo, se brinca al siguiente archivo.
Sub correo()
'Por.Dante Amor
col = Range("H1").Column
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = Range("B" & i).Value 'Destinatarios
dam.CC = Range("C" & i).Value 'Con copia
dam.Bcc = Range("D" & i).Value 'Con copia oculta
dam.Subject = Range("E" & i).Value '"Asunto"
dam.body = Range("F" & i).Value '"Cuerpo del mensaje"
'
For j = col To Cells(i, Columns.Count).End(xlToLeft).Column
archivo = Cells(i, j).Value
If archivo <> "" Then
If Dir(archivo) <> "" Then
dam.Attachments.Add archivo
End If
End If
Next
dam.Send 'El correo se envía en automático
Next
MsgBox "Correos enviados", vbInformation, "SALUDOS"
End Sub'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Con esta macro los archivos que no existan se pondrán en negrita
Sub File_Exist()
Dim FilePath As String
Dim TestStr As String
col = Range("H1").Column
For i = 1 To Range("B" & Rows.Count).End(xlUp).Row
FilePath = Cells(i, col).Value
TestStr = ""
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
If TestStr = "" Then Cells(i, col).Font.Bold = True
Next
End Sub
Muchísimas gracias por tu macro, gregori, pero no me funciona. Más bien me ignora olímpicamente :-(
¿En las celdas de la columna H tienes las rutas?
Algo como C:\temp\archivos\ventas.xls
Sí. Pero no son archivos xls sino pdf, y están en una unidad en red. Así: M:\7.-Nóminas\N2\RECIBOS EMAIL\archivo.pdf
Prueba a poner las rutas entre comillas "M:\7.-Nóminas\N2\RECIBOS EMAIL\archivo.pdf"
¡Gracias!
Perdona la tardanza en contestarte. Lo puse entrecomillado y tampoco me funciona :-(
Si tienes el Microsoft Scripting Runtime activado en las referencias del editor de macros
Aqui te explica como hacerlo si no sabes
https://msdn.microsoft.com/es-es/library/office/gg264402.aspx