Problema con macro al envio de datos por correo

[tutamen]

Hola, 

Un compi me ha ayudado a crear una macro para reenviar los datos un excel por correo. La macro parece que funciona, ya que en función del valor de un una columna, filtra los datos y va a buscar un correo electronico en una hoja adjunta. El problema, es que cuando envio el correo funciona, pero me he dado cuenta que cuando me reenvian el correo desaparece el filtro y se ven los datos de todas las agencia... Lo cual es un problema.  Os copio el código por si podéis ayudarme.

 

Gracias, 

 

Option Explicit

Private Sub btnBuscarExcel_Click()
Dim sNombreFichero As String

On Error GoTo Control_Error

    Dim fd As Office.FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    With fd
        .InitialFileName = "C:\"
        .Title = "Seleccione un fichero Excel"
        .Filters.Clear
        .Filters.Add "Archivos Excel", "*.xlsx?"
        .AllowMultiSelect = False
                
        If .Show = True Then
            sNombreFichero = .SelectedItems(1)
            lblNombreFichero.Caption = sNombreFichero
        End If
    End With
    
Control_Error:
    If Err.Number <> 0 Then
        MsgBox "Error al buscar el fichero Excel", vbExclamation, ""
    End If
End Sub

Private Sub btnCancelar_Click()
    Unload Me
End Sub

Private Sub btnEnviarCorreo_Click()
Dim objExcel        As Excel.Application
Dim objLibroExcel   As Excel.Workbook
Dim objHojaExcel    As Excel.Worksheet
Dim lFila            As Long
Dim lColumna         As Long
Dim cAgencias       As New Collection
Dim sClave          As String
Dim sAgencia        As String
Dim sCorreo         As String
Dim datosAgencia() As String
Dim i               As Long

On Error GoTo Control_Error

    If MsgBox("Se van a enviar los correos. Esto puede tardar unos minutos." & vbCrLf & _
    "¿Desea Continuar?", vbQuestion + vbYesNo) = vbYes Then

        'PROCESAR EXCEL
        Set objExcel = New Excel.Application
    
        Set objLibroExcel = objExcel.Workbooks.Open(lblNombreFichero.Caption, ReadOnly:=True)
        objLibroExcel.Activate
        
        lFila = 2 'Fila 1 son cabeceras
        lColumna = 1
        objLibroExcel.Worksheets(1).Activate
        Set objHojaExcel = objLibroExcel.ActiveSheet
    
        'Obtenemos el número de agencias diferentes de la hoja2 con su dirección de correo.
        objLibroExcel.Worksheets(2).Activate
        Set objHojaExcel = objLibroExcel.ActiveSheet
         
        While Trim(objHojaExcel.Cells(lFila, 2)) <> ""
            sAgencia = Trim(objHojaExcel.Cells(lFila, 2))
            sCorreo = Trim(objHojaExcel.Cells(lFila, 3))
            cAgencias.Add sAgencia & "*/*" & sCorreo
            lFila = lFila + 1
        Wend
        sCorreo = ""
        sAgencia = ""
            
        'COMIENZA EL ENVÍO DE CORREOS
        objLibroExcel.Worksheets(1).Activate
        Set objHojaExcel = objLibroExcel.ActiveSheet
        
        'Ajusto ancho de las columnas al texto de la J a N
        objHojaExcel.Columns("A:Z").AutoFit
                               
        'Muestro el Excel porque sino da error EnvelopeVisible
        objExcel.Visible = True
        objExcel.WindowState = xlMinimized
        
        For i = 1 To cAgencias.Count
            objExcel.EnableEvents = False
            objExcel.ScreenUpdating = False
            
            datosAgencia = Split(cAgencias.Item(i), "*/*")
            sAgencia = datosAgencia(0)
            sCorreo = datosAgencia(1)
            objExcel.Selection.AutoFilter
            objExcel.ActiveSheet.Range("$A$1:$Q$1401").AutoFilter Field:=13, Criteria1:=sAgencia
                                                
            lblInfoCorreo.Caption = "Por favor, espere... Enviando correo a " & sAgencia & " (" & i & " de " & cAgencias.Count & ")"
                                                
            'Mostramos la sección para enviar correo y ocultamos las alertas
            objExcel.DisplayAlerts = False
            objLibroExcel.EnvelopeVisible = True
                        
            'Llamamos al envío...
            With objHojaExcel.MailEnvelope
                .Item.To = sCorreo
                .Item.Subject = sAgencia & "-" & txtAsunto.Text
                .Introduction = txtCuerpo.Text
                .Item.Send
            End With
        Next i
        'FIN ENVIO DE CORREOS
        objExcel.DisplayAlerts = True
        objExcel.ScreenUpdating = True
        objExcel.EnableEvents = True
        
        lblInfoCorreo.Caption = ""
        MsgBox "Fin del proceso", vbInformation, ""
    End If

Control_Error:
    If Err.Number <> 0 Then
        If Not objLibroExcel Is Nothing Then
            objExcel.DisplayAlerts = True
        End If
        objExcel.ScreenUpdating = True
        objExcel.EnableEvents = True
        lblInfoCorreo.Caption = ""
        MsgBox "Error al enviar el correo." & Err.Number & " - " & Err.Description, vbExclamation, ""
    End If
    
    If Not objLibroExcel Is Nothing Then
        objLibroExcel.Close SaveChanges:=False
    End If
    
    Set objHojaExcel = Nothing
    Set objLibroExcel = Nothing
    Set objHojaExcel = Nothing
End Sub
    
 
Muchas gracias chicos. 

[Abraham Valencia]

Hola

Cuando dices que te reenvían ¿te refieres a que descargan, manipulan y luego te vuelven a enviar dicho archivo? De ser eso, pues basta que esa persona, o personas, desactiven los filtros, guarden y ya, obvio no estará como tú lo dejaste. ¿O te refieres a otra cosa?

[tutamen]

Hola, 

 

Me explico mejor, siempre ha sido mi problema.

No es un archivo adjunto, porque lo que hace la macro es filtrar de un fichero excel y anexar los datos  en el cuerpo del email. El problema, es que lo hace bien cuando lo envía, pero cuando alguien hace un forward o me contesta a mi propio correo, se quita el filtro de datos que envié y aparecen todos los valores sin filtrar. 

 

Gracias por vuestra ayuda. 

[tutamen]

Hola, 

Me pasa lo mismo que a esta persona, pero no soy capaz de ver donde tengo que modificar el código para solucionar el problema.  Agradecería ayuda. Mil gracias cracks.

[Abraham Valencia]

Quizá 20 años sin usar esa opción y al menos 15 que di alguna explicación sobre dicho método jejeje, pero hasta donde recuerdo, para evitar lo que te está sucediendo, y ya habiéndolo entendido mejor, prueba enviando solo el rango visible y no toda la hoja como haces actualmente ( Set objHojaExcel = objLibroExcel.ActiveSheet y objHojaExcel.MailEnvelope). Mira el segundo ejemplo de esta página:

 https://www.rondebruin.nl/win/s1/outlook/bmail3.htm

El enlace que enviaste lo que hace es copiar en otra hoja solo lo filtrado y enviar desde dicha hoja, es una alternativa que no deberías desechar. Lo otro es que use el objeto Outlook, pero deberías aprender a programarlo y no sé si el código que envías lo hiciste tú y por ende sabes algo de VBA.

[tutamen]

Muchas gracias por tu respuesta. Algo sé de vb, pero estoy aprendiendo a marchas forzadas. Voy a intentarlo.  Gracias,