Modificación parámetros macro para envió mails desde Excel

El genio de Dante genero una macro para envió de mails automáticos, funciona genial, solo que use la celda que hace el match para la consolidación del rango a enviar por mail, y donde busca correos, el tema es que en el asunto del mail, me sale ese código, me gustaría poder modificarla para que me mande otra celda.

Hoja de rango de celdas en N el match para consolidar y búsqueda de mails en la base

Base mails

Me gustaría que el asunto de mail que hoy sale como "P40, le comparto el estado de OC al29/03/2021" use la columna G de la base de mails que tiene el nombre del proveedor. Y que quede "3M grupomontone le comparto el estado de OC al29/03/2021"

¿Se podrá?

No me deja pegar el código porque me paso de caracteres, dejo el archivo que estoy usando con la macro en un drive

Archivo

1 respuesta

Respuesta
1

Te anexo el código actualizado:

Sub Enviar_Correo_a_Proveedores()
'Por Dante Amor
  Dim c As Range, f As Range
  Dim sh As Worksheet, s2 As Worksheet, s3 As Worksheet
  Dim ky As Variant
  '
  With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
  End With
  '
  Set sh = Sheets("ResumenProv")
  Set s2 = Sheets("Base Mails Proveedores")
  Set s3 = Sheets.Add
  '
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range("N6", sh.Range("N" & Rows.Count).End(3))
      If c.Value <> "" Then
        Set f = s2.Range("A:A").Find(c, , xlValues, xlWhole)
        If Not f Is Nothing Then
          .Item(c.Value) = f.Offset(0, 3).Value & "|" & f.Offset(0, 6).Value
        End If
      End If
    Next c
    For Each ky In .Keys
      s3.Cells.Clear
      sh.Range("A5").AutoFilter Columns("N").Column, ky
      sh.AutoFilter.Range.EntireRow.Copy s3.Range("A1")
      Call Mail_Selection_Range_Outlook_Body(s3, ky, Split(.Item(ky), "|")(0), Split(.Item(ky), "|")(1))
    Next ky
  End With
  sh.ShowAllData
  s3.Delete
  '
  With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With
End Sub
'
Sub Mail_Selection_Range_Outlook_Body(s3, prov, correo, razon)
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
  Dim rng As Range
  Dim OutApp As Object
  Dim OutMail As Object
  '
  On Error Resume Next
  Set rng = s3.Range("A1:M" & s3.Range("A" & Rows.Count).End(3).Row)
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)
  '
  With OutMail
    .To = correo
    .Subject = razon & ", le comparto el estado de OC al " & Format(Date, "dd/mm/yyyy")
    .HTMLBody = "Estimado proveedor le informamos el estado de sus órdenes <br>" & _
                RangetoHTML(rng) & _
                "<br> Muchas gracias."
    .Display  'cambiar a .Send para enviar
  End With
  On Error GoTo 0
  '
  Set rng = Nothing
  Set OutMail = Nothing
  Set OutApp = Nothing
End Sub
'
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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"
    'TempFile = "C:\trabajo\temp.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
        .Columns("A:M").WrapText = False
        .Columns("A:M").EntireColumn.AutoFit
        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

Mis más sincera admiración por tu trabajo, realmente lo haces parecer fácil y es un montón! Estaba enviando mail por mail y esto me facilita la vida muchísimo, las gracias me quedan cortas, sos un genio muchas gracias!

Saludos!

Con gusto, podrías cambiar la valoración.

Estas líneas cambiaron

 .Item(c.Value) = f.Offset(0, 3).Value & "|" & f.Offset(0, 6).Value
Call Mail_Selection_Range_Outlook_Body(s3, ky, Split(.Item(ky), "|")(0), Split(.Item(ky), "|")(1))
Sub Mail_Selection_Range_Outlook_Body(s3, prov, correo, razon)
.Subject = razon & ", le comparto el estado de OC al " & Format(Date, "dd/mm/yyyy")

Parece sencillo pero tiene su nivel de complejidad.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas