Modify the code for sending different emails to Multiple E-Mails

Hany ali · Mar 10, 2021

hi my Dear ,I Hope to help me to Modify this code to Send all Emails one Time For all List From Column F .. With everything related to this email of data found from Column A To Column E

Code:

Option Explicit
Sub Sent()
       Dim Wks    As Worksheet
    Dim OutMail As Object
    Dim OutApp As Object
    Dim myRng  As Range
    Dim list   As Object
    Dim item   As Variant
    Dim LastRow As Long
    Dim uniquesArray()
    Dim Dest   As String
    Dim strbody
        Set list = CreateObject("System.Collections.ArrayList")
    Set Wks = ThisWorkbook.Sheets("Total Supplier Cost ")
        With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
        With Wks
        For Each item In .Range("E2", .Range("E" & .Rows.Count).End(xlUp))
            If Not list.Contains(item.Value) Then list.Add item.Value
        Next
    End With
        For Each item In list
                Wks.Range("A1:F" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=5, Criteria1:=item
        'Set OutApp = CreateObject("Outlook.Application")
        Set OutApp = Outlook.Application
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
                LastRow = Cells(Rows.Count, "A").End(xlUp).Row
        Set myRng = Wks.Range("A1:C" & LastRow).SpecialCells(xlCellTypeVisible)
        
        Dest = Cells(LastRow, "F").Value
        strbody = "Dear ," & "<br>" & _
                  "See the Total Cost" & "<br/><br>"
                With OutMail
            .To = Dest
            .CC = ""
            .BCC = ""
            .Subject = "Invoice From" & " " & Sheet8.Range("M1") & " " & "To" & " " & Sheet8.Range("N1")
            .HTMLBody = strbody & RangetoHTML(myRng)
            .Display
            '.Send
        End With
        On Error GoTo 0
    Next
        On Error Resume Next
    Wks.ShowAllData
    On Error GoTo 0
        With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    End Sub
Function RangetoHTML(myRng As Range)
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim fso    As Object
    Dim ts     As Object
    Dim i      As Integer
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    myRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=1
        .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
                For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    End With
        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
    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=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Kenneth Hobson · Mar 11, 2021

There is nothing in column E. Maybe there is in your main dataset.

Since you are using arraylist already, just add another. e.g.

Code:

Sub Sent()
    'https://chandoo.org/forum/threads/vba-to-filter-data-based-on-column-and-copy-to-the-body-of-the-mail.45912/
    Dim Wks    As Worksheet
    Dim OutMail As Object
    Dim OutApp As Object
    Dim myRng  As Range
    Dim list   As Object
    Dim item   As Variant
    Dim LastRow As Long
    Dim uniquesArray()
    Dim Dest   As String
    Dim strbody
    Dim r As Range, emails
    
    Set list = CreateObject("System.Collections.ArrayList")
    Set emails = CreateObject("System.Collections.ArrayList")
    Set Wks = ThisWorkbook.Sheets("Total Supplier Cost")
    With Application
      .EnableEvents = False
      .ScreenUpdating = False
    End With
    With Wks
    MsgBox .Range("E2", .Range("E" & .Rows.Count).End(xlUp)).Address
      For Each item In .Range("E2", .Range("E" & .Rows.Count).End(xlUp))
        If Not list.Contains(item.Value) Then list.Add item.Value
      Next
    End With
    For Each item In list
      Wks.Range("A1:F" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=5, Criteria1:=item
        emails.Clear
      For Each r In Wks.Range("F2", Wks.Cells(Rows.Count, "F").End(xlUp)).SpecialCells(xlCellTypeVisible)
        If Not emails.Contains(r) Then emails.Add r
      Next r
      'Set OutApp = CreateObject("Outlook.Application")
      Set OutApp = Outlook.Application
      Set OutMail = OutApp.CreateItem(0)
      On Error Resume Next
      LastRow = Cells(Rows.Count, "A").End(xlUp).Row
      Set myRng = Wks.Range("A1:C" & LastRow).SpecialCells(xlCellTypeVisible)
    
      'Dest = Cells(LastRow, "F").Value
      Dest = Join(emails.toarray, ";")
      strbody = "Dear ," & "<br>" & _
        "See the Total Cost" & "<br/><br>"
      With OutMail
        .To = Dest
        .CC = ""
        .BCC = ""
        .Subject = "Invoice From" & " " & Sheet1.Range("M1") & " " & "To" & " " & Sheet1.Range("N1")
        .HTMLBody = strbody & RangetoHTML(myRng)
        .Display
        '.Send
      End With
      On Error GoTo 0
    Next
    On Error Resume Next
    Wks.ShowAllData
    On Error GoTo 0
    With Application
      .EnableEvents = True
      .ScreenUpdating = True
    End With
End Sub
Function RangetoHTML(myRng As Range)
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim fso    As Object
    Dim ts     As Object
    Dim i      As Integer
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    myRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=1
        .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
                For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    End With
        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
    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=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Hany ali · Mar 11, 2021

Thank you very much .. But after i press Ok From This Message ,it does not work with me and makes the file and heavy it
and I Want to Send The e-mail even no data in Column E

Kenneth Hobson · Mar 11, 2021

Rather than column E, you might want to filter by column A.

I don't know what "heavy it" means.

There is a special case where specialcells does not work as one expects. When that happens, it goes into a very long loop that makes it look like an infinite loop. I did a work-around for that.

The html table has more blank rows in it. I would have to look into that issue more. A scratch sheet might be the better route.

Since you have a button, activesheet assumption would make code a bit easier and skip the need for Wks.

Code:

Sub Sent()
    'https://chandoo.org/forum/threads/vba-to-filter-data-based-on-column-and-copy-to-the-body-of-the-mail.45912/
    Dim Wks    As Worksheet
    Dim OutMail As Object, OutApp As Object, myRng  As Range
    Dim list   As Object, item, LastRow As Long, uniquesArray()
    Dim Dest As String, strbody As String
    Dim r As Range, rr As Range, emails
   
    Set list = CreateObject("System.Collections.ArrayList")
    Set emails = CreateObject("System.Collections.ArrayList")
    Set Wks = ThisWorkbook.Sheets("Total Supplier Cost")
    'Set OutApp = CreateObject("Outlook.Application")
    Set OutApp = Outlook.Application

    With Application
      .EnableEvents = False
      .ScreenUpdating = False
    End With
   
    With Wks
      For Each item In .Range("E2", .Range("E" & .Rows.Count).End(xlUp))
        If Not list.Contains(item.Value) Then list.Add item.Value
      Next item
   
      For Each item In list
        .Range("A1:F" & Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter Field:=5, Criteria1:=item
        emails.Clear
        Set rr = .Range(.Range("F2"), .Cells(.Rows.Count, "F").End(xlUp)).SpecialCells(xlCellTypeVisible)
        If rr.Column = 1 Then Set rr = Wks.Range("F2")
        For Each r In rr
          If Not emails.Contains(r) Then emails.Add r
        Next r
       
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
       
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set myRng = .Range("A1:C" & LastRow).SpecialCells(xlCellTypeVisible)
   
        'Dest = Cells(LastRow, "F").Value
        Dest = Join(emails.toarray, ";")
        strbody = "Dear ," & "<br>See the Total Cost" & "<br/><br>"
        With OutMail
          .To = Dest
          .CC = ""
          .BCC = ""
          .Subject = "Invoice From" & " " & .Range("M1") & " " & "To" & " " & .Range("N1")
          .HTMLBody = strbody & RangetoHTML(myRng)
          .Display
          '.Send
        End With
        On Error GoTo 0
      Next item
      On Error Resume Next
      .ShowAllData
    End With
   
    On Error GoTo 0
    With Application
      .EnableEvents = True
      .ScreenUpdating = True
    End With
End Sub


Function RangetoHTML(myRng As Range)
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim fso    As Object
    Dim ts     As Object
    Dim i      As Integer
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    myRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=1
        .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
                For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    End With
        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
    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=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Hany ali · Mar 13, 2021

I apologize very much for my delay in responding due to my internet interruption, and I thank you very much for your response ... but I sent you some notes when applying the code
and in photo 2 the e-Mail Forme after Sent as shown all data appear for all person ,but I want One By One

Kenneth Hobson · Mar 13, 2021

See post #4

Hany ali · Mar 14, 2021

thanks
Kenneth Hobson
allready this Result as you see in my Screen in Post 5 After i Run and Used Code from Post#4

Hany ali · Mar 14, 2021

thanks alot my dear Now it's work good ..but i have two Notes
first one I want to Receive my email as you see in Picture no.2 not as I received allready like in Picture No.1
Second thing ,I want to Fix this Line from the Code because i want to send e-mails by Subject Not without as i get it now

Code:

Subject = "Invoice From" & " " & .Range("M1") & " " & "To" & " " & .Range("N1")

Also, I am facing a problem in sending the email because all the data of the columns from column A to E are formulas for fetching data from another page. In the presence of the equations, the email is sent empty without any data. Is there a solution for that?

Kenneth Hobson · Mar 14, 2021

The subject line should be changed to:

Code:

.Subject = "Invoice From " & myRng.Range("M1") & " To " & myRng.Range("N1")

I guess I would need an example file with the formulas that are not right(blank) after the autofilter. It works as expected with your sample file. At worst, one can task the macro to copy data to a scratch sheet and change formulas to values and autofilter that worksheet. I normally like to create a temporary workbook to do that.

I would recommend commenting .Send while testing. I put Exit Sub after .Display when I test. After tested, comment .Display or delete and uncomment .Send. When testing, it is often best to comment out On Error to find errors like the .Subject line had.

Hany ali · Mar 15, 2021

thanks alot for You,Now Subject is ok ..but as you see I want all date from Column E To Shown in e-mail after I Send Not Part from Data as you see
I deeply apologize for you, for I have tired you a lot, may God bless you for your patience and bear all my troubles and problems

Kenneth Hobson · Mar 15, 2021

#10 is because you did not autofit your data's columns. Either do it manually or the macro can do it.

I see your problem with the formulas. The publish to html routine does not handle those formulas apparently. To solve this do one of:
1. Macro to create a scratch sheet in master workbook and filter that.
2. Macro to create a temporary workbook and copy/paste the data and filter that.
3. Use another Outlook method that does not use the htlmbody. There are two other methods. One let's you use Word methods to paste a copied range to the body of the email.
4. Attach an xlsx file with just the filtered data so the simple outlook body method would suffice.

Hany ali · Mar 15, 2021

thanks my Dear ,If solving the problem in this way is impossible .. I can do it manually

Kenneth Hobson · Mar 15, 2021

Why impossible? I said a macro can do it. Recording a macro can help you learn some syntax. Or, in the first With:

Code:

 With WKS
    .UsedRange.EntireColumn.AutoFit
    'and other code....
  End With

Hany ali · Mar 16, 2021

sorry my dear .. In which part exactly do I put this code ,Because when I put it i founf this after i send

Code:

Sub Sent()
    'https://chandoo.org/forum/threads/vba-to-filter-data-based-on-column-and-copy-to-the-body-of-the-mail.45912/
    Dim Wks    As Worksheet
    Dim OutMail As Object, OutApp As Object, Subject, myRng As Range
    Dim list   As Object, item, LastRow As Long, uniquesArray()
    Dim Dest As String, strbody As String
    Dim r As Range, rr As Range, emails
  
    Set list = CreateObject("System.Collections.ArrayList")
    Set emails = CreateObject("System.Collections.ArrayList")
    Set Wks = ThisWorkbook.Sheets("Total Supplier Cost")
    'Set OutApp = CreateObject("Outlook.Application")
    Set OutApp = Outlook.Application
    With Application
      .EnableEvents = False
      .ScreenUpdating = False
    End With
       With Wks
                      For Each item In .Range("E2", .Range("E" & .Rows.Count).End(xlUp))
                      If Not list.Contains(item.Value) Then list.Add item.Value
      Next item
         For Each item In list
        .Range("A1:F" & Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter Field:=5, Criteria1:=item
        emails.Clear
        Set rr = .Range(.Range("F2"), .Cells(.Rows.Count, "F").End(xlUp)).SpecialCells(xlCellTypeVisible)
        If rr.Column = 1 Then Set rr = Wks.Range("F2")
        For Each r In rr
          If Not emails.Contains(r) Then emails.Add r
        Next r
      
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
      
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set myRng = .Range("A1:E" & LastRow).SpecialCells(xlCellTypeVisible)
  
        'Dest = Cells(LastRow, "F").Value
        Dest = Join(emails.toarray, ";")
        strbody = "Dear ," & "<br>See the Total Cost" & "<br/><br>"
        With OutMail
          .To = Dest
          .CC = ""
          .BCC = ""
        .Subject = "Invoice From " & myRng.Range("M1") & " To " & myRng.Range("N1")
          .HTMLBody = strbody & RangetoHTML(myRng)
          .Display
          .Send
        End With
        On Error GoTo 0
      Next item
      On Error Resume Next
      .ShowAllData
    End With
  
    On Error GoTo 0
    With Application
      .EnableEvents = True
      .ScreenUpdating = True
    End With
End Sub


Function RangetoHTML(myRng As Range)
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim fso    As Object
    Dim ts     As Object
    Dim i      As Integer
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    myRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=1
        .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
                For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    End With
        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
    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=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Kenneth Hobson · Mar 16, 2021

Yes, that is the problem that I told you about in #11. Below is method (2).

There is an issue in selecting the range with data due to your formulas. The usual CurrentRegion, UsedRange, and End methods will not suffice. I can write code to find last row in column A with data. For now, see if this does what you need.

Once the emails popup, give it a bit of time so that all the filtered examples are displayed.

Code:

Option Explicit

Sub Sent()
    'https://chandoo.org/forum/threads/vba-to-filter-data-based-on-column-and-copy-to-the-body-of-the-mail.45912/
    Dim Wks  As Worksheet, Wks2 As Worksheet
    Dim OutMail As Object, OutApp As Object, Subject, myRng As Range
    Dim list   As Object, item, LastRow As Long, uniquesArray()
    Dim Dest As String, strbody As String
    Dim r As Range, rr As Range, emails
  
    Set Wks = ThisWorkbook.Sheets("Total Supplier Cost")
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    Set list = CreateObject("System.Collections.ArrayList")
    Set emails = CreateObject("System.Collections.ArrayList")
    Set Wks = ThisWorkbook.Sheets("Total Supplier Cost")
    'Set OutApp = CreateObject("Outlook.Application")
    Set OutApp = Outlook.Application
  
    Wks.UsedRange.Copy
    'Scratch workbook method
    Set Wks2 = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
  
    With Wks2 'working with scratch workbook now...
      .[A1].PasteSpecial xlValues
      .[A1].PasteSpecial xlPasteFormats
      .[A1].PasteSpecial xlPasteFormats
      .UsedRange.EntireColumn.AutoFit
      
      'Get uniques values in column E to filter
      For Each item In .Range("E2", .Range("E" & .Rows.Count).End(xlUp))
        If Not list.Contains(item.Value) Then list.Add item.Value
      Next item
  
      For Each item In list
        .Range("A1:F" & Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter Field:=5, Criteria1:=item
        emails.Clear
        Set rr = .Range(.Range("F2"), .Cells(.Rows.Count, "F").End(xlUp)).SpecialCells(xlCellTypeVisible)
        If rr.Column = 1 Then Set rr = Wks.Range("F2")
        For Each r In rr
          If Not emails.Contains(r) Then emails.Add r
        Next r
      
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
      
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set myRng = .Range("A1:E" & LastRow).SpecialCells(xlCellTypeVisible)
  
        'Dest = Cells(LastRow, "F").Value
        Dest = Join(emails.toarray, ";")
        strbody = "Dear ," & "<br>See the Total Cost" & "<br/><br>"
        With OutMail
          .To = Dest
          .CC = ""
          .BCC = ""
        .Subject = "Invoice From " & myRng.Range("M1") & " To " & myRng.Range("N1")
          .HTMLBody = strbody & RangetoHTML(myRng)
          .Display
          '.Send
        End With
        On Error GoTo 0
      Next item
      On Error Resume Next
      '.ShowAllData
      '.UsedRange.AutoFilter 'Turn off autofilter
      .Parent.Close False 'Close scratch workbook
    End With
  
    On Error GoTo 0
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub


Function RangetoHTML(myRng As Range)
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim fso    As Object
    Dim ts     As Object
    Dim i      As Integer
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    myRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=1
        .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
                For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    End With
        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
    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=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Hany ali · Mar 16, 2021

Thank you so much, you are really creative and that is what is really needed

Modify the code for sending different emails to Multiple E-Mails

Hany ali

Active Member

Attachments

Kenneth Hobson

Active Member

Hany ali

Active Member

Attachments

Kenneth Hobson

Active Member

Hany ali

Active Member

Attachments

Kenneth Hobson

Active Member

Hany ali

Active Member

Hany ali

Active Member

Attachments

Kenneth Hobson

Active Member

Hany ali

Active Member

Attachments

Kenneth Hobson

Active Member

Hany ali

Active Member

Kenneth Hobson

Active Member

Hany ali

Active Member

Attachments

Kenneth Hobson

Active Member

Hany ali

Active Member