Problema con macro al envio de datos por correo

tutamen · el 7 de mayo

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 · el 7 de mayo

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 · el 7 de mayo

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 · el 7 de mayo

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 · el 7 de mayo

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.