Macro crea copia de la hoja activa la guarda una carpeta y envía la copia por correo electrónico
Tengo una hoja de Excel llamada "concentrado" que es un formato donde introduzco datos la cual genera un consecutivo en la celda (b4) cada vez que se abre el libro, y ocupo que al pulsar un botón muestre un msjbox preguntando si quiere gurdar una copia, al aceptar crea una carpeta la primera vez y en ella guarde una copia de la hoja activa con el nombre del consecutivo de la celda (b4) pero que la guarde sin macros osea en xlsx y la envíe por correo electrónico la dirección del correo a enviar esta en la celda (p38), el asunto del correo esta en (p39) y el mensaje se encuentra en (p40), si hubiera un error muestre en msjbox diciendo "proceso no completado intente de nuevo" y de lo contrario si no hay error diga "proceso satisfactorio desea salir " y de la opción de salir cerrando el libro.
Espero que sea clara la idea y puedan ayudarme saludos a toda la comunidad de expertos ...
1 respuesta
.07/12/16 #VBA Procedimiento de generación y envío de archivo xlsx por mail
Buenas, Alfredo
Aquí va el procedimiento que solicitaste.
Accede al Editor de VBA (Atajo: Alt + F11), allí inserta un módulo (Insertar-Módulo) y pega el siguiente código:
Sub GenerArch()
'---- Variables modificables ----
'=== ALFREDO, modifica estos datos de acuerdo a tu proyecto:
HojaOrig = "Concentrado" 'hoja donde están los datos
CeldaArch = "B4" 'celde donde está el nombre a dar al archivo
LaCarpeta = "C:\2mails" '"C:\Mis documentos"
DirMail = "P38" ' celda con dirección de mail de destino
TitMail = "P39" ' celda con asunto del mail
TextMail = "P34" ' celda con Texto del mail
Muestra = No ' No = Envía directamente. Sino Muestra el mail para que sea revisado y luego enviado
'---- fin Variables
'
'---- inicio de rutina:
'
'1.- CONSULTA DE INICIO DE RUTINA DE GENERACION DE COPIA.
'
ElMensaje = "Se lanzó el procedimiento de guardar y enviar automáticamente el archivo: " & Chr(10) & Range(CeldaArch).Value & Chr(10) & "a la siguiente dirección:" & Chr(10) & Range(DirMail).Value & Chr(10) & Chr(10) & "¿Desea continuar?"
ElTitulo = "ENVIAR COPIA DE ESTA HOJA"
QueHago = MsgBox(ElMensaje, vbOKCancel + vbQuestion, ElTitulo)
If QueHago = vbOK Then
'2.- Control de Existencia del Carpeta
'
LaCarpeta = LaCarpeta & IIf(Right(LaCarpeta, 1) = "\", "", "\")
On Error Resume Next
ChDir LaCarpeta
If Err = 76 Then
Err = 0
QueHago = MsgBox("la carpeta " & LaCarpeta & " NO existe." & Chr(10) & "¿La creo?", vbOKCancel, "NO ESTA ¿QUE HAGO?")
If QueHago = 1 Then
MkDir LaCarpeta
Else
ElMensaje = "Ha cancelado el proceso" & Chr(10) & "No se crea carpeta y termina rutina"
ElTitulo = "PROCESO INTERRUMPIDO POR EL USUARIO"
MsgBox ElMensaje, vbInformation, ElTitulo
Exit Sub
End If
End If
On Error GoTo 0
'3.- Creación y guardado de copia en la carpeta
'
ElArchivo = Range(CeldaArch).Value
ElArchivo = ElArchivo & IIf(Right(LaCarpeta, 5) = ".xlsx", "", ".xlsx")
Sheets(HojaOrig).Copy
Application.DisplayAlerts = False 'elimina la línea si quieres que te pregunte por reemplazar archivo existente.
ActiveWorkbook.SaveAs Filename:=LaCarpeta & ElArchivo, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close xlNo
Application.DisplayAlerts = True
'4.- Envío de mail
'
Dim objOL As New Outlook.Application
Dim objMail As MailItem
Set objOL = New Outlook.Application
Set objMail = objOL.CreateItem(olMailItem)
With objMail
.To = Range(DirMail).Value
.Subject = Range(TitMail).Value
.Body = Range(TextMail).Value
.Importance = olImportanceHigh 'High importance
.Attachments.Add (LaCarpeta & ElArchivo)
If UCase(Muestra) <> "NO" Then
.Display 'muestra mensaje
Else
On Error Resume Next
.Send
End If
'5.- Mensajes de estado de envío de mail
'
If Err.Number <> 0 Then
ElMensaje = "Se ha producido el ERROR:" & Chr(10) & Err.Description & "No se ha enviado el mail. Favor revisar" & Chr(10) & "Termina rutina aqui"
TipoMens = vbCritical
ElTitulo = "MAIL NO ENVIADO"
Else
ElMensaje = "MAIL enviado satisfactoriamente a:" & Chr(10) & Range(DirMail).Value & Chr(10) & "con el archivo: " & Chr(10) & "ElArchivo" & Chr(10) & "Proceso terminado OK."
TipoMens = vbInformation
ElTitulo = "MAIL ENVIADO CORRECTAMENTE"
End If
MsgBox ElMensaje, TipoMens, ElTitulo
Err.Clear
On Error GoTo 0
End With
Set objMail = Nothing
Set objOL = Nothing
Else
ElMensaje = "Ha cancelado el proceso" & Chr(10) & "No se envió mail alguno"
ElTitulo = "PROCESO INTERRUMPIDO POR EL USUARIO"
MsgBox ElMensaje, vbInformation, ElTitulo
End If
End SubNota que, al principio del código, hay unas variables para que lo adaptes a tu archivo, pero -en principio- responde a los datos que proporcionaste.
Sólo te faltó indicar cuál es el nombre de la carpeta donde guardar la copia. Allí verás una variable donde se lo puedes escribir. Eventualmente puede modificarse para que lo tome de alguna celda, así como toma el nombre del archivo.
Va a depender mucho de cuál es tu vía de envío de mails, pero las pruebas que le hice funcionaron ok en mi equipo.
Ten presente que para el envío via outlook debes marcar la referencia de Outlook Object Library. Para eso en el mismo Editor de VBA ve al menú Herramientas > Referencias.
Y marca lo que está en amarillo:
Como notarás, tu consulta tiene bastante complejidad. Espero que te sea satisfactoria mi respuesta.
Después me dirás si te funcionó -y, en tal caso, agradeceré que califiques mi contribución- o escribeme de nuevo aquí, si necesitas más apoyo con esto.
Un abrazo
Fernando
.
Buen día fer, amigo un gusto poder saludarte de nuevo, gracias por el apoyo te comento mis resultados, ya que me manda el mensaje de error 9 en tiempos de ejecución, sub indice fuera de intervalo y me marca con amarillo la línea :
Sheets(HojaOrig).Copy
¿A qué se refiere? ¿Qué debo hacer?
Como quedaría el código para poder delimitar el grupo de celdas que ocupa la planilla de la cual, se esta guardando y enviando para no enviar toda la hoja ya que fuera de esta limite hay botones e imágenes que no tiene caso que se guarden y envíen, la planilla esta desde (a1) hasta (bw37), gracias fer...
.
Hola, Alfredo
Respecto al error, parece que no estaba con ese nombre la hoja a exportar.
Es importante que revises los contenidos de las variables que están al principio del código porque ellas orientan a la rutina para operar.
A la versión que te paso ahora, le agregué una donde le puedes definir el rango que quieres llevar.
Me llama la atención que los datos para mandar el mail (P38:P40) estén dentro del rango que exportas (A1:BW37), así como el nombre del archivo. Pero tu sabrás por qué.
Eventualmente, ya sabes, puedes modificarlos en esas variables.
Bien, éste código genera un archivo nuevo donde pega el rango que le indiques como valor:
Sub GenerArch()
'---- Variables modificables ----
'=== ALFREDO, modifica estos datos de acuerdo a tu proyecto:
HojaOrig = "Concentrado" 'hoja donde están los datos
RangoExport = "A1:BW37"'Rango a llevar a nuevo archivo
CeldaArch = "B4" 'celda donde está el nombre a dar al archivo
LaCarpeta = "C:\Mis documentos"
DirMail = "P38" ' celda con dirección de mail de destino
TitMail = "P39" ' celda con asunto del mail
TextMail = "P40" ' celda con Texto del mail
Muestra = No ' No = Envía directamente. Sino Muestra el mail para que sea revisado y luego enviado
'---- fin Variables
'
'---- inicio de rutina:
'
'1.- CONSULTA DE INICIO DE RUTINA DE GENERACION DE COPIA.
'
ElMensaje = "Se lanzó el procedimiento de guardar y enviar automáticamente el archivo: " & Chr(10) & Range(CeldaArch).Value & Chr(10) & "a la siguiente dirección:" & Chr(10) & Range(DirMail).Value & Chr(10) & Chr(10) & "¿Desea continuar?"
ElTitulo = "ENVIAR COPIA DE ESTA HOJA"
QueHago = MsgBox(ElMensaje, vbOKCancel + vbQuestion, ElTitulo)
If QueHago = vbOK Then
'2.- Control de Existencia del Carpeta
'
LaCarpeta = LaCarpeta & IIf(Right(LaCarpeta, 1) = "\", "", "\")
On Error Resume Next
ChDir LaCarpeta
If Err = 76 Then
Err = 0
QueHago = MsgBox("la carpeta " & LaCarpeta & " NO existe." & Chr(10) & "¿La creo?", vbOKCancel, "NO ESTA ¿QUE HAGO?")
If QueHago = 1 Then
MkDir LaCarpeta
Else
ElMensaje = "Ha cancelado el proceso" & Chr(10) & "No se crea carpeta y termina rutina"
ElTitulo = "PROCESO INTERRUMPIDO POR EL USUARIO"
MsgBox ElMensaje, vbInformation, ElTitulo
Exit Sub
End If
End If
On Error GoTo 0
'3.- Creación y guardado de copia en la carpeta
'
ElArchivo = Range(CeldaArch).Value
ElArchivo = ElArchivo & IIf(Right(LaCarpeta, 5) = ".xlsx", "", ".xlsx")
Sheets(HojaOrig).Range(RangoExport).Copy
Workbooks.Add
ActiveSheet.Range(RangoExport).PasteSpecial Paste:=xlPasteColumnWidths
ActiveSheet.Range(RangoExport).PasteSpecial Paste:=xlPasteValues
ActiveSheet.Range(RangoExport).PasteSpecial Paste:=xlPasteFormats
Application.DisplayAlerts = False 'elimina la línea si quieres que te pregunte por reemplazar archivo existente.
ActiveWorkbook.SaveAs Filename:=LaCarpeta & ElArchivo, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close xlNo
Application.DisplayAlerts = True
'4.- Envío de mail
'
Dim objOL As New Outlook.Application
Dim objMail As MailItem
Set objOL = New Outlook.Application
Set objMail = objOL.CreateItem(olMailItem)
With objMail
.To = Range(DirMail).Value
.Subject = Range(TitMail).Value
.Body = Range(TextMail).Value
.Importance = olImportanceHigh 'High importance
.Attachments.Add (LaCarpeta & ElArchivo)
If UCase(Muestra) <> "NO" Then
.Display 'muestra mensaje
Else
On Error Resume Next
.Send
End If
'5.- Mensajes de estado de envío de mail
'
If Err.Number <> 0 Then
ElMensaje = "Se ha producido el ERROR:" & Chr(10) & Err.Description & "No se ha enviado el mail. Favor revisar" & Chr(10) & "Termina rutina aqui"
TipoMens = vbCritical
ElTitulo = "MAIL NO ENVIADO"
Else
ElMensaje = "MAIL enviado satisfactoriamente a:" & Chr(10) & Range(DirMail).Value & Chr(10) & "con el archivo: " & Chr(10) & "ElArchivo" & Chr(10) & "Proceso terminado OK."
TipoMens = vbInformation
ElTitulo = "MAIL ENVIADO CORRECTAMENTE"
End If
MsgBox ElMensaje, TipoMens, ElTitulo
Err.Clear
On Error GoTo 0
End With
Set objMail = Nothing
Set objOL = Nothing
Else
ElMensaje = "Ha cancelado el proceso" & Chr(10) & "No se envió mail alguno"
ElTitulo = "PROCESO INTERRUMPIDO POR EL USUARIO"
MsgBox ElMensaje, vbInformation, ElTitulo
End If
End SubEspero que ahora sí esté como quieres.
Saludos
Fer
.
Como siempre fer todos tus trabajos impecables pero esta vez de verdad te luciste ¡Gracias!
tu amigo Alfredo p.g
p.d el sistema trabaja impecable pero no aparecen los correos en la bandeja de entrada ni el la de no deceados por que puede estar sucediendo fer?...
.
Me alegro de que te haya servido.
Fue un buen ejercicio.
Respecto a lo tu bandeja de entrada, imagino que debe ser algún problema de configuración del Servidor de correos que uses.
Un abrazo
Fer
.
