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

Respuesta
1

.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 Sub

Nota 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 Sub

Espero 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

.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

Al seleccionar celda extraer sus dígitos automáticamente

Necesito dos favores, la idea es que al seleccionar una celda numérica de 4 dígitos del rango "af1;aj42" esta automáticamente extraiga sus cifras a la columna "a1, b1, c1, d1" como se muestra en la imagen Y lo segundo como puedo quitarle el msgbox a...
2 respuestas

Se puede agregar voz a Excel

Tengo una pantalla de vuelo de vuelo donde anotó despegues y arribos, Quiero que cada vez que se produzca un despegue y se agregue hora o aterrice alguno y se ponga la hora, excel diga o se escuche atención Aterrizaje o Atención despegue.
3 respuestas

Gráfico Comparativo por Semanas, en Power Bi.

Espero se encuentren muy bien. Tengo una tabla en Power BI con fechas, códigos, costos y cantidades. La necesidad que tengo es de crear un gráfico o tabla donde pueda comparar y analizar el comportamiento de los costos y las cantidades de un código...
1 respuesta

En una lista para pedidos tengo varios formularios

En una lista para pedidos con varios formularios la vengo usando desde hace tiempo sin ningún problema pero hace días la abrí para hacer un pedido y al pisar en el cuadro donde apunta la flecha para que me abra un otro cuadro donde coloco ciertos...
2 respuestas

Código VBA para crear un botón y guardar en PDF

Tengo un archivo word con 7 capturas, una en cada página (1-7), cual seria el código para crear un botón en la barra de herramientas de acceso rápido para convertir en PDF cada página. El resultado seria 7 pdf.
2 respuestas

Como evitar que se duplique un dato en la base de datos

Trato que al ingresar los datos a la base de datos si en la columna "B" DNI es una cifra que ya esta en dicha base me lo indique en un Msgbox "El Dato ya existe" Esta es la macro que tengo en el botón Aceptar Private Sub Aceptar_Click()...
2 respuestas

Detectar si he marcado Celda dentro de un Rango de Excel.

Tengo un Rango en Hoja Excel: RgoDatos >> $B$3:$V$39 Quiero detectar si la celda que selecciono está dentro de ese Rango Si no está que por omisión me marque B3.
1 respuesta

Desproteger un rango de celdas en una hoja protegida

Tengo una aplicación donde en una hoja se ponen comentarios automáticos con una macro, pero como hay celdas donde hay fórmulas las tengo bloqueadas y ocultas para que no se borren por error al usarla, tengo puesto el Unprotect en la macro por que si...
8 respuestas

Dato fecha ya existe en tabla

Como están estimados maestros. En formulario, tengo botón archivar. Envío información a hoja "existencias" a tabla "tbl_existencias". En columna A un Código desde textbox1 En columna B fecha desde textbox "txtFecha2" En columna C total desde textbox2...
2 respuestas

Enviar hoja activa al monitor secundario con vba

He creado una segunda ventana de mi hoja excel con NewWindow, y lo que pretendo es mediante código VBA enviarla al monitor secundario, lo he intentado con Application.SendKeys "^({ESC}+{RIGHT})", pero no lo consigo, con "^{ESC}" estoy tratando de...
2 respuestas