VBA Enviar hojas Excel por correo (Outlook) según el nombre de la hoja
Tengo un libro con diferentes hojas con el nombre de unas personas (p. Ej. PEDRO, LUIS, ANA, ELENA,...)
En otra hoja ("SELECCIÓN"), tengo una lista con algunos de esos nombres (K8:K19)
He hecho un BUSCARV para tener en la columna L de la hoja SELECCIÓN las direcciones de correo de estas personas (puede ser más de 1 dirección). Podría poner en las siguientes columnas el asunto u otras datos si fuera necesario para la macro.
Necesito que se envíen por correo las hojas de la lista K8:K19, cada una a su destinatario correspondiente.
No quiero guardar copia de cada uno de los archivos enviados en el pc, con tenerlo en el libro origen me es suficiente.
Seguiré investigando a ver si lo consigo pero mis nociones de VBA son muy básicas...
1 respuesta
Te anexo la macro
Sub Enviar_Hoja()
'Por Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
Set l1 = ThisWorkbook
Set h1 = Sheets("SELECCION")
'
ruta = l1.Path & "\"
arch = "libro.xlsx"
For i = 8 To h1.Range("K" & Rows.Count).End(xlUp).Row
existe = False
hoja = h1.Cells(i, "K").Value
If hoja <> "" Then
For Each h In Sheets
If LCase(h.Name) = LCase(hoja) Then
existe = True
Exit For
End If
Next
If existe Then
Sheets(hoja).Copy
Set l2 = ActiveWorkbook
l2.SaveAs ruta & arch, FileFormat:=xlOpenXMLWorkbook
l2.Close
'
'DATOS DEL CORREO
correo = h1.Cells(i, "L").Value 'correo para
asunto = h1.Cells(i, "M").Value 'asunto
cuerpo = h1.Cells(i, "N").Value 'asunto
'
'ENVIAR CORREO
Set dam = CreateObject("Outlook.Application").CreateItem(0)
dam.To = correo
dam.Subject = asunto
dam.Body = cuerpo
dam.Attachments.Add ruta & arch
dam.Send 'El correo se envía en automático
'dam.Display 'El correo se muestra
End If
End If
Next
MsgBox "Hojas enviadas por correo"
End SubSolamente puse un destinatario de correo que lo va a tomar de la columna L, pero si observas la lógica de la macro puedes agregar más datos al correo.
Avísame cualquier duda sobre la macro.
.Sal u dos. Dante Amor. No olvides valorar la respuesta.
Muchísimas gracias Dante! Es justo lo que necesitaba!
Simplemente le he modificado el nombre del fichero (de "libro" a "PLAN") para el receptor lo pueda identificar mejor, y he añadido una orden para borrar dicho fichero temporal una vez que termine la macro.
Sub Enviar_Hoja()
'Por Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
Set l1 = ThisWorkbook
Set h1 = Sheets("SELECCIÓN")
'
ruta = l1.Path & "\"
arch = "PLAN.xlsx"
'Desde la celda K8 hasta la siguiente vacía en esa columna. Si se quiere enviar
'también el Plan completo a alguien de la empresa, habría que poner desde i=7
For i = 8 To h1.Range("K" & Rows.Count).End(xlUp).Row
existe = False
Hoja = h1.Cells(i, "K").Value
If Hoja <> "" Then
For Each h In Sheets
If LCase(h.Name) = LCase(Hoja) Then
existe = True
Exit For
End If
Next
If existe Then
Sheets(Hoja).Copy
Set l2 = ActiveWorkbook
l2.SaveAs ruta & arch, FileFormat:=xlOpenXMLWorkbook
l2.Close
'
'DATOS DEL CORREO
correo = h1.Cells(i, "L").Value 'correo para
asunto = h1.Cells(i, "M").Value 'asunto
cuerpo = h1.Cells(i, "N").Value 'cuerpo
'
'ENVIAR CORREO
Set dam = CreateObject("Outlook.Application").CreateItem(0)
dam.To = correo
dam.Subject = asunto
dam.Body = cuerpo
dam.Attachments.Add ruta & arch
'dam.Send 'El correo se envía en automático
dam.Display 'El correo se muestra
End If
End If
Next
Kill (ruta & arch)
MsgBox "Hojas enviadas por correo"
End SubSólo me quedaría pendiente una cosa para dejarlo perfecto:
Si en la columna K se indica un nombre que se corresponde con una hoja pero, en la columna L no hay ninguna dirección de correo --> la macro se detiene porque no puede enviar el email.
¿Sería posible agregar una rutina que haga las dos cosas siguientes? :
1- Si falta la dirección de email en L, mostrar un mensaje de aviso en pantalla
2- Continuar enviando el resto de correos
Podría "esquivar" el problema poniendo una dirección ficticia o algo así pero, si fuera posible agregar los pasos anteriores sería genial.
Gracias otra vez!
Te anexo el código para validar el correo
Sub Enviar_Hoja()
'Por Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
Set l1 = ThisWorkbook
Set h1 = Sheets("SELECCIÓN")
'
ruta = l1.Path & "\"
arch = "PLAN.xlsx"
'Desde la celda K8 hasta la siguiente vacía en esa columna. Si se quiere enviar
'también el Plan completo a alguien de la empresa, habría que poner desde i=7
For i = 8 To h1.Range("K" & Rows.Count).End(xlUp).Row
existe = False
Hoja = h1.Cells(i, "K").Value
If Hoja <> "" Then
For Each h In Sheets
If LCase(h.Name) = LCase(Hoja) Then
existe = True
Exit For
End If
Next
If existe Then
Sheets(Hoja).Copy
Set l2 = ActiveWorkbook
l2.SaveAs ruta & arch, FileFormat:=xlOpenXMLWorkbook
l2.Close
'
'DATOS DEL CORREO
Correo = h1.Cells(i, "L").Value 'correo para
asunto = h1.Cells(i, "M").Value 'asunto
cuerpo = h1.Cells(i, "N").Value 'cuerpo
'
'ENVIAR CORREO
If Correo = "" Then
MsgBox "Falta el correo en la fila : " & i
Else
Set dam = CreateObject("Outlook.Application").CreateItem(0)
dam.To = Correo
dam.Subject = asunto
dam.Body = cuerpo
dam.Attachments.Add ruta & arch
'dam.Send 'El correo se envía en automático
dam.Display 'El correo se muestra
End If
End If
End If
Next
Kill (ruta & arch)
MsgBox "Hojas enviadas por correo"
End SubNo olvides valorar la respuesta.
Buenos días Dante
Funciona perfectamente! Muchas gracias por el tiempo que te has tomado. Me has ahorrado muchísimo tiempo en mi trabajo.
Gracias otra vez y un saludo!
