Enviar hoja de Excel por correo

Tengo un Formulario que registra cierta información en una hoja de Excel y posteriormente por medio de un botón se envía por correo electrónico, Mi duda es ¿como hago para que se envié la hoja del libro que tiene el formulario, ya que si oculto el libro envía la hoja que este visible aunque fuera de cualquier otro libro abierto.

La macro que estoy utilizando es la siguiente:

Private Sub CommandButton4_Click()
 If UserForm1.OptionButton3 = False And UserForm1.OptionButton4 = False Then
        MsgBox "Selecciona un destinatario"
        Exit Sub
    End If
    If UserForm1.OptionButton3 = True Then
        destinatario = "[email protected]"
    Else
        destinatario = "[email protected]"
    End If
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim OA, OM As Object
    Dim NA As Variant
    Dim Path, TD, fn, mydoc As String
    TD = Format(Date, "dd/mm/yyyy")
    Path = ThisWorkbook.Path & "\"
    fn = ActiveSheet.Name
    mydoc = Path & fn & ".xlsx"
    mydoc1 = Path & fn & ".pdf"
    Dest = Cells(3, "E")
    Sheets(fn).Copy
    ActiveWorkbook.SaveAs Filename:=mydoc, FileFormat:=xlOpenXMLWorkbook
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    mydoc1, Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    ActiveWorkbook.Close False
    Set OA = CreateObject("Outlook.Application")
    Set OM = OA.CreateItem(0)
    With OM
    .To = destinatario
    .CC = ""
    .BCC = ""
    .Subject = "Solicitud de Ticket"
    .Body = "Estimados, en el archivo adjunto se encuentra la solicitud de Ticket con fecha " & TD & " . Su apoyo para generar la solicitud. Favor de confirmar recepción"
    .Attachments.Add mydoc
    .Send
    End With
    If Err.Number = 0 Then
    SendMail_Gmail = True
    MsgBox "El mail con archivo adjunto fue enviado con éxito", vbInformation, "AVISO"
    Else
    MsgBox "Se produjo el siguiente error: " & Err.Description, vbCritical, "Error nro " & Err.Number
    End If
    Kill mydoc
    Kill mydoc1
    Set OM = Nothing
    Set OA = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Unload Me
    Unload UserForm1
End Sub

1 Respuesta

Respuesta
2

Te anexo la macro con los cambios

Private Sub CommandButton4_Click()
    If UserForm1.OptionButton3 = False And UserForm1.OptionButton4 = False Then
        MsgBox "Selecciona un destinatario"
        Exit Sub
    End If
    If UserForm1.OptionButton3 = True Then
        destinatario = "[email protected]"
    Else
        destinatario = "[email protected]"
    End If
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim OA, OM As Object
    Dim NA As Variant
    Dim Path, TD, fn, mydoc As String
    TD = Format(Date, "dd/mm/yyyy")
    Path = ThisWorkbook.Path & "\"
    '
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets("nombrehoja")
    fn = h1.Name
    '
    mydoc = Path & fn & ".xlsx"
    mydoc1 = Path & fn & ".pdf"
    Dest = Cells(3, "E")
    'Sheets(fn).Copy
    h1.Copy
    ActiveWorkbook.SaveAs Filename:=mydoc, FileFormat:=xlOpenXMLWorkbook
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        mydoc1, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    ActiveWorkbook.Close False
    Set OA = CreateObject("Outlook.Application")
    Set OM = OA.CreateItem(0)
    With OM
    .To = destinatario
    .CC = ""
    .BCC = ""
    .Subject = "Solicitud de Ticket"
    .Body = "Estimados, en el archivo adjunto se encuentra la solicitud de Ticket con fecha " & TD & " . Su apoyo para generar la solicitud. Favor de confirmar recepción"
    .Attachments.Add mydoc
    .Send
    End With
    If Err.Number = 0 Then
    SendMail_Gmail = True
    MsgBox "El mail con archivo adjunto fue enviado con éxito", vbInformation, "AVISO"
    Else
    MsgBox "Se produjo el siguiente error: " & Err.Description, vbCritical, "Error nro " & Err.Number
    End If
    Kill mydoc
    Kill mydoc1
    Set OM = Nothing
    Set OA = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Unload Me
    Unload UserForm1
End Sub

.

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

.

Avísame cualquier duda

.

Cambia en la macro "nombrehoja" por el nombre de la hoja que quieras enviar.

Avísame cualquier duda

.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas