Enviar mail, tomando las direcciones de una celda especifica
Para Dante Amor
Hola, necesito que me des una mano con un problema que tengo. Tengo un excel que al guardar se genera un PDF y lo adjunta a un correo que tiene las direcciones asociadas, todo en una macro que me hiciste. EL problema es que tengo que darle mucho mantenimiento. ¿Hay posibilidades que las direcciones de correo las cargue en una celda y depende quien use la planilla mande el mail?
Sub GuardarPDF()
Dim hojas()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ruta = "C:\Ventas\Ordenes de Facturación\
n = -1
For Each h In Sheets
If h.[G4] <> "" Then
n = n + 1
ReDim Preserve hojas(n)
hojas(n) = h.Name
If nomb = "" Then
nomb = [G4] & " " & Format(Range("G2"), "dd-mm-yyyy") + Format(Now, "(hh'mm)") & ".pdf"
End If
End If
Next
If n > -1 Then
Sheets(hojas).Copy
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ruta & nomb, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
ActiveWorkbook.Close False
'
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = "[email protected]; [email protected]; [email protected]"
dam.Subject = nomb
dam.Body = "Orden de Pedido"
dam.Attachments.Add ruta & nomb
dam.Display 'El correo se envía en automático
'dam.Display 'El correo se muestra
'
MsgBox "Orden lista para enviar, favor revisar correo"
End If
End Sub
1 Respuesta
H o l a : Vamos a configurar tu archivo de excel de la siguiente forma:
1. Crea una hoja nueva en tu archivo y le pones por nombre "usuarios".
2. En la columna A vas a poner los nombres de equipo que van a ocupar el archivo. Para ver el nombre del equipo, selecciona con el botón derecho en Mi Pc, Propiedades, Nombre de equipo.
3. En la columna B vas a poner los correos, ver imagen:
Cambia la macro por la siguiente:
Sub GuardarPDF()
'Por.Dante Amor
Dim hojas()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ruta = "C:\Ventas\Ordenes de Facturación\"
'ruta = "C:\trabajo\"
n = -1
For Each h In Sheets
If h.[G4] <> "" Then
n = n + 1
ReDim Preserve hojas(n)
hojas(n) = h.Name
If nomb = "" Then
nomb = h.[G4] & " " & Format(h.Range("G2"), "dd-mm-yyyy") + Format(Now, "(hh'mm)") & ".pdf"
End If
End If
Next
'
If n > -1 Then
usuario = Environ$("computername")
Set h = Sheets("usuarios")
Set b = h.Columns("A").Find(usuario)
If b Is Nothing Then
MsgBox "El usuario: " & usuario & " no existe en la hoja 'usuarios'", vbCritical
Exit Sub
End If
'
correos = b.Offset(0, 1)
Sheets(hojas).Copy
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ruta & nomb, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
ActiveWorkbook.Close False
'
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = correos
dam.Subject = nomb
dam.Body = "Orden de Pedido"
dam.Attachments.Add ruta & nomb
dam.Display 'El correo se envía en automático
'dam.Display 'El correo se muestra
'
MsgBox "Orden lista para enviar, favor revisar correo"
End If
End SubAhora la macro obtiene el nombre de la PC donde se está ejecutando, busca ese nombre en la hoja "usuarios", si lo encuentra obtiene los correos de los destinatarios y envía el correo.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
