Buenas tardes. Amigos muchas gracias por la ayuda que siempre me han proporcionado, esta vez tengo una macro que ya me funciona pero solo para enviar un correo a la vez y manualmente tengo que estar cambiando en el codigo el correo y la hoja, me gustaria conocer si existe la forma de dentro de mi libro tengo 20 o 30 hojas (nunca es el mismo numero), cada hoja tiene el mismo formato, rango de datos, etc.. a excepción de la información que contiene cada hoja.

Lo que me gustaría conocer es como hacer que en una hoja tenga una lista de correos (EMAIL) y vaya recorriendo y enviando el rango que le corresponde, es decir:

ColumnaA ColumnaB

Nombre hoja Correo correspondiente

Dato1 dato1@son.com

Dato2 dato2@son.com

Por lo tanto cuando este la hoja de nombre Dato1 enviara el rango a dato1@son.com, después la hoja Dato2 y lo enviara a dato2@son.com, y asi recorro todas lass hojas y envio el rango de la hoja al correo que el corresponde y asi sucesivamente,

Llevo la parte de recorrer la hoja EMAIL. pero no me envia los mails a la persona que le corresponde.

De ante mano gracias por su atención y ayuda.

Envio de mail.xls

Hola Gerardo, tal vez aqui encuentres lo que necesitas:

Mail from Excel and make/mail PDF files (Windows)

Muchas gracias por tu respuesta Armando Montes, ya rebusque en la pagina y no encuentro algo que se adapte o tal vez mi poca experiencia con Macros haga que no pueda adaptar mi codigo, inclusive de ahi saque el codigo que ahora utlizo, unicamente me falta como esa parte de enviar el correo a la persona que el corresponde.

Me falta muy poco para lograr mi cometido... alguien me puede guiar que hacer... creo que el paso que estoy haciendo mal es mihoja = ActiveSheet.Name y aqui Set rng = Sheets(mihoja).Range("A1:Q12").SpecialCells(xlCellTypeVisible) espero alguien me pueda ayudar con este problema... Muchas gracias

Option Explicit


Sub Mail_Range_Outlook_Body()


    Dim rng As Range

    Dim OutApp As Object

    Dim OutMail As Object

     Dim valor, mihoja As String

    Dim hoja As Object

    '***************************************************

  Sheets("EMAIL").Select

  Range("a1").Select

  Do While ActiveCell.Value <> ""

  valor = ActiveCell.Value

    For Each hoja In ActiveWorkbook.Sheets

If UCase(hoja.Name) = UCase(valor) Then

mihoja = ActiveSheet.Name



'*************************CODIGO ORGINAL**********************************

    With Application

        .EnableEvents = False

        .ScreenUpdating = False

    End With


    Set rng = Nothing

    On Error Resume Next

    Set rng = Sheets(mihoja).Range("A1:Q12").SpecialCells(xlCellTypeVisible)

    On Error GoTo 0

    If rng Is Nothing Then

        MsgBox "La selección no es un rango o la hoja está protegida" & _

              vbNewLine & "Por favor, corrija y vuelva a intentarlo.", vbOKOnly

        Exit Sub

    End If


    Set OutApp = CreateObject("outlook.application")

    Set OutMail = OutApp.CreateItem(0)


    On Error Resume Next

    With OutMail

        .To = Cells(i, "B")

        .CC = ""

        .BCC = ""

        .Subject = "Mi asunto"

        .HTMLBody = RangetoHTML(rng)

        '.HTMLBody = strbody & vbNewLine & vbNewLine & Signature

        '.display 'or use .Send

        .send

    End With

    On Error GoTo 0

    With Application

        .EnableEvents = True

        .ScreenUpdating = True

    End With

    Set OutMail = Nothing

    Set OutApp = Nothing


'**************************************TERMINA CODIGO ORIGINAL**************************


End If

Next

ActiveCell.Offset(1, 0).Select

Loop



End Sub[/CODE]

Amigos perdon que insista tanto, pero ya estoy a nada de lograrlo, me pueden ayudar con este ultimo paso... veran me envia el correo de acuerdo aLque le corresponde pero me lo envia doble...

Option Explicit


Sub Mail_Range_Outlook_Body()


    Dim rng As Range

    Dim OutApp As Object

    Dim OutMail As Object

    Dim ufila, i As Integer

    Dim j As Integer

    Dim valor, mihoja, valorb As String

    Dim hoja As Object


    '***************************************************

  Sheets("EMAIL").Select

  ufila = Range("B" & Rows.Count).End(xlUp).Row

    For j = ufila To 1 Step -1

  'For j = 1 To ufila

  Range("a1").Select

  Do While ActiveCell.Value <> ""

  valor = ActiveCell.Value

  'Range("b1").Select

  'Do While ActiveCell.Value <> ""

  'valorb = ActiveCell.Value

    For Each hoja In ActiveWorkbook.Sheets

If UCase(hoja.Name) = UCase(valor) Then

mihoja = hoja.Name


'*************************CODIGO ORGINAL**********************************

    With Application

        .EnableEvents = False

        .ScreenUpdating = False

    End With




    Set rng = Nothing

    On Error Resume Next

    Set rng = Sheets(mihoja).Range("A1:Q12").SpecialCells(xlCellTypeVisible)

    On Error GoTo 0

    If rng Is Nothing Then

        MsgBox "La selección no es un rango o la hoja está protegida" & _

              vbNewLine & "Por favor, corrija y vuelva a intentarlo.", vbOKOnly

        Exit Sub

    End If


    Set OutApp = CreateObject("outlook.application")

    Set OutMail = OutApp.CreateItem(0)


    On Error Resume Next

    With OutMail

        .To = Cells(j, "B") '(valorb)

        .CC = ""

        .BCC = ""

        .Subject = "Mi asunto"

        .HTMLBody = RangetoHTML(rng)

        '.HTMLBody = strbody & vbNewLine & vbNewLine & Signature

        '.display 'or use .Send

        .send

    End With

    On Error GoTo 0

    With Application

        .EnableEvents = True

        .ScreenUpdating = True

    End With

    Set OutMail = Nothing

    Set OutApp = Nothing


'**************************************TERMINA CODIGO ORIGINAL**************************


End If

Next

ActiveCell.Offset(1, 0).Select

'Loop

Loop

Next j


End Sub[/CODE]

Lo logre!!

TEMA FINALIZADO