Enviar rango en cuerpo de correo por cada hoja.

Hola a todos. Muchas gracias por este excelente foro que no sirve de mucho a los que estamos en camino de aprender. Verán tengo un código el cual me funciona, hasta cierto punto... Si quiero enviar correo por persona me deja, pero aquí tengo mas de 10 destinatarios diferentes y no se de que forma puedo enviar la información que le corresponde a cada uno.

Tengo un libro con 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 y vaya recorriendo y enviando el rango que le corresponde, es decir:

ColumnaA ColumnaB

Dato1 [email protected]

Dato2 [email protected]

Por lo tanto cuando este la hoja de nombre DAato1 enviara el rango a [email protected], después recorre al Dato2 y envía el rango de la hoja al correo que el corresponde y asi sucesivamente,

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

Option Explicit
Sub Mail_Range_Outlook_Body()
 Dim rng As Range
 Dim OutApp As Object
 Dim OutMail As Object
 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 = "[email protected]"
 .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
 Set MyRango = Nothing
End Sub
ption Explicit
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
 Dim fso As Object
 Dim ts As Object
 Dim TempFile As String
 Dim TempWB As Workbook
 TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 'Copy the range and create a new workbook to past the data in
 rng.Copy
 Set TempWB = Workbooks.Add(1)
 With TempWB.Sheets(1)
 .Cells(1).PasteSpecial Paste:=8
 .Cells(1).PasteSpecial xlPasteValues, , False, False
 .Cells(1).PasteSpecial xlPasteFormats, , False, False
 .Cells(1).Select
 Application.CutCopyMode = False
 On Error Resume Next
 .DrawingObjects.Visible = True
 .DrawingObjects.Delete
 On Error GoTo 0
 End With
 'Publish the sheet to a htm file
 With TempWB.PublishObjects.Add( _
 SourceType:=xlSourceRange, _
 Filename:=TempFile, _
 Sheet:=TempWB.Sheets(1).Name, _
 Source:=TempWB.Sheets(1).UsedRange.Address, _
 HtmlType:=xlHtmlStatic)
 .Publish (True)
 End With
 'Read all data from the htm file into RangetoHTML
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
 RangetoHTML = ts.readall
 ts.Close
 RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
 "align=left x:publishsource=")
 'Close TempWB
 TempWB.Close savechanges:=False
 'Delete the htm file we used in this function
 Kill TempFile
 Set ts = Nothing
 Set fso = Nothing
 Set TempWB = Nothing
End Function