Использование VBA для создания электронных писем из Excel, которые объединяют тело письма при дублировании адресов

Question

Во-первых, я очень новичок в VBA.Все еще учусь, поэтому, возможно, я совершаю некоторые очевидные ошибки.

Я пытаюсь создавать электронные письма, используя электронную таблицу Excel, из которой я извлекаю информацию, чтобы заполнить сообщения «Кому», «Тема» и «Тело».Они собираются к продавцам, чтобы просмотреть информацию для своих клиентов.Мне нужно, чтобы каждое электронное письмо было основано на клиенте и отправлено соответствующим торговым представителям.У некоторых клиентов есть несколько строк информации, в то время как у других есть один, а у некоторых продавцов пересекающиеся клиенты.

Код, который я нашел и пытался редактировать, (насколько я могу судить) строит электронные письма на основена адресах электронной почты.В итоге я получаю электронное письмо с указанием продавца в строке «Кому», а в теле есть все клиенты специально для этого продавца.В то же время тема затрагивает только одного клиента, которого должно отображать электронное письмо.

Любая помощь по этому вопросу будет находкой.Я пытаюсь уменьшить рабочую нагрузку на 4-6 часов до 1 часа.

Каждый раз, когда я пытаюсь внести изменения в код, чтобы основывать его на клиенте, а не на адресе электронной почты, я либо заканчиваю тем, что нарушалкодировать или не создавать электронное письмо и вместо этого каким-то образом просто применить фильтр к электронной таблице, который фильтрует ту же информацию, которая была в электронном письме до изменения.

Я чувствую, что может потребоваться больше информации, потому что я 'Я считаю, что это гораздо сложнее, чем кажется, но это может быть из-за того, что я слишком много думаю.Я пытался ограничить этот пост только соответствующей информацией, но если мне потребуется предоставить больше, я, конечно, буду.Я ломал голову над этим в течение нескольких недель.

Я пробовал различные операторы If And / Then, чтобы попытаться заставить код взглянуть на столбец customer, а не на столбец email, но я не могунайти любую комбинацию, которая работает.Код, который я разместил ниже, - это то, что мне удалось в какой-то степени заставить работать.Так как я пробовал так много вариантов, я бы не знал, что было бы лучшей ошибкой для включения.Так что, надеюсь, это, по крайней мере, не слишком грязно.

* Редактировать: Код требует столбец имен в столбце А, который, насколько я понял, должен был быть условием, что «для этого имени создается электронная почтаиспользуя адрес в столбце B.Но то, что он делает, - это создание электронного письма с использованием адреса в столбце B в качестве условия.Таким образом, любая строка клиента в A, которая соответствует адресу в B, добавляется в тот же адрес электронной почты.Мне нужно, чтобы все было наоборот.Одно электронное письмо от каждого клиента из столбца A на все адреса электронной почты, перечисленные в столбце B.

Edit2: информация об источнике выглядит примерно так:

+----------------+---------------------+---------+--------------+
|     Customer   |       Email         | Subj Ln |  Email Body  |
+----------------+---------------------+---------+--------------+
| Customer 1     | sales1@address.com  | info    |     info     |
| Customer 2     | sales2@address.com  | info    |     info     |
| Customer 2     | sales2@address.com  | info    |     info     |
| Customer 2     | sales2@address.com  | info    |     info     |
| Customer 3     | sales2@address.com  | info    |     info     |
| Customer 4     | sales3@address.com  | info    |     info     |
| Customer 4     | sales3@address.com  | info    |     info     |
| Customer 5     | sales1@address.com  | info    |     info     |
| Customer 6     | sales4@address.com  | info    |     info     |
+----------------+---------------------+---------+--------------+

Таким образом, код должен выглядеть наСтолбец клиента (столбец A) и поиск уникальных экземпляров, после чего создается электронное письмо с соответствующим адресом электронной почты в столбце электронной почты (столбец B).Каждый из них должен быть отдельным адресом электронной почты, и когда адреса электронной почты являются уникальными для клиента, он это сделает.Итак, в приведенном выше примере Customer 6 получает единственное электронное письмо с sales4.Электронное письмо генерирует соответствующую строку темы и текст сообщенияОднако Клиент 1 сгенерирует электронное письмо с соответствующим Subj Ln и телом электронной почты (для Клиента 1), и у него также будет соответствующий адрес электронной почты sales1.Но поскольку у sales1 также есть Клиент 5, информация об электронной почте для Клиента 5 включена в электронное письмо Клиента 1.Когда мне нужно, чтобы клиент 5 был отдельным электронным письмом.

Edit3: я добавил следующий абзац в качестве комментария ниже, потому что я не был уверен, что будет лучшим способом показать его.

Я еще немного поигрался с кодом и думаю, что, возможно, нашел что-то, чего раньше не понимал полностью. Я не уверен, что я все еще делаю, но я думаю, что у меня есть лучшее понимание. - Похоже, код создает фильтр, который он использует для создания тела письма. Он фильтрует столбец B (электронные письма) на предмет уникальных значений и создает электронную почту на основе этого. Я думаю, что если я смогу изменить этот код фильтра для фильтрации по столбцу A и создать письмо, используя столбец B, то я думаю, что получу то, что ищу. Я просто не могу понять, как заставить это работать.

Надеюсь, я в порядке. Это становится очень запутанным и подавляющим для меня, но я надеюсь, что это имеет смысл. Кроме того, я надеюсь, что мое форматирование правильное.

Sub Send_Row_Or_Rows_2()

Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet

'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A1:AY" & Ash.Rows.Count)
FieldNum = 2    'Filter column = B because the filter range start in 
column A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=Cws.Range("A1"), _
        CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
    For Rnum = 2 To Rcount

        'Filter the FilterRange on the FieldNum column
        FilterRange.AutoFilter Field:=FieldNum, _
                               Criteria1:=Cws.Cells(Rnum, 1).Value

        'If the unique value is a mail addres create a mail
        If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

            With Ash.AutoFilter.Range
                On Error Resume Next
                Set rng = .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
            End With

            Set OutMail = OutApp.CreateItem(0)

            On Error Resume Next
            With OutMail
                .To = Cws.Cells(Rnum, 1).Value
                .Subject = Ash.Cells(Rnum, 3) & " Bond Review " & Date
                .HTMLBody = RangetoHTML(rng)
                .Display  'Or use Send
            End With
            On Error GoTo 0

            Set OutMail = Nothing
        End If

        'Close AutoFilter
        Ash.AutoFilterMode = False

    Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Function RangetoHTML(rng As Range)

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

Public Function EOMonth(dInput As Date)

LastDayOfMonth = DateSerial(Year(dInput()), Month(dInput() + 1), -1)

End Function

Answer 1

Я написал такой код довольно много раз - базовый шаблон на самом деле на моем github

Код:

Option Explicit


Sub LoopOverData()
Dim STbl As ListObject
Dim LastRow As Long
Dim WB As Workbook
Dim i As Long
Dim WS As Worksheet
Dim tblwsname As String


    Set WB = ThisWorkbook


    tblwsname = WB.Names("TblWSName").RefersToRange.Value2
    Set WS = WB.Sheets(tblwsname)
    Set STbl = WS.ListObjects("EmailDataTable")


    LastRow = STbl.ListRows.Count


    For i = 1 To LastRow
         WB.Names("IterationNumber").RefersToRange.Value2 = i
         Application.Calculate
         Call CreateEmail
    Next i



End Sub





Sub CreateEmail()
' This macro is for the pricing confirm e-mail
    Dim outApp As New Outlook.Application
    Dim OutMail As Object
    Dim Attchmnt As String
    Dim Signature As String
    Dim WB As Workbook
    Set WB = ThisWorkbook
   Attchmnt = WB.Names("Attachment").RefersToRange.Value2
   'We keep the file path for the attachment we're sending in Excel, for easy editing. Look in name manager to find it.

    Application.EnableEvents = False
     Application.ScreenUpdating = False

    ' We don't need the screen to flicker while the macro is running - it speeds things up.
    Set OutMail = outApp.CreateItem(0)
    'Signature = OutMail.Body
    On Error Resume Next
    With OutMail
    .To = WB.Names("to").RefersToRange.Value2
   .CC = WB.Names("cc").RefersToRange.Value2
   .BCC = WB.Names("bcc").RefersToRange.Value2
   .Subject = WB.Names("Subject").RefersToRange.Value2
   .Body = WB.Names("Body").RefersToRange.Value2
   .display
   End With

   If Attchmnt = "" Then
   Else
   OutMail.Attachments.Add Attchmnt
   End If

   'OutMail.send
   'Remove this comment to directly send. Not recommended.

   On Error GoTo 0
End Sub

Настройка: вы в основном создаете «образец электронного письма» и используете = index (Range, IndexNum), чтобы определить, над каким элементом вы работаете в настоящее время. IndexNum - это именованный диапазон назад к базовому индексу, который будет изменяться кодом.

Следовательно, по мере перемещения каждого числа в индексе все формулы обновляются до нового электронного письма, которое необходимо записать. Затем он вызывает процедуру создания электронной почты и создает (но не отправляет) необходимую электронную почту. Это дает вам возможность просмотреть электронные письма перед их отправкой.

Вы хотите, чтобы библиотека объектов Microsoft Outlook 16.0 была включена.

Возможно, есть какое-то правило для отправки информации, которую я пропускаю - если это так, я рекомендую несколько формул или мощный запрос, чтобы выполнить сжатие

Answer 2

Если я правильно понимаю, вы хотите отправлять электронные письма, основанные на уникальной комбинации клиента и адреса электронной почты, и для каждой уникальной комбинации получить соответствующую строку темы и текст сообщения.Таким образом, в приведенном выше примере я предполагаю, что, поскольку customer2 и Customer4 являются дубликатами, тогда вы хотите отправить только одно электронное письмо для каждого клиента и использовать соответствующую строку темы и текст сообщения, найденные при первом появлении Cutomer2 или 4.

Если мои предположения верны, то код ниже должен сделать эту работу.Обратите внимание на комментарии, которые объясняют каждый шаг.

Редактировать: Я забыл упомянуть, что использование разделителя, как я делал изначально, рискованно, потому что этот разделитель может существовать где-то в данных, и расщепление этим разделителем приведет к потере ваших результатов.Итак, лучший способ (и я считаю, более чистым) был бы следующим:

Option Explicit

Public Sub SendEmails()

 Dim objDict As Object
 Dim objWB As Workbook
 Dim objWS As Worksheet
 Dim rngToLookUp As Range
 Dim lngLastRow As Long, i As Long
 Dim arryEmailData As Variant
 Dim objOutlookApp As Object, objOutlookEmail As Object
 Dim varKey As Variant, arryTemp As Variant

    Application.ScreenUpdating = False

    Set objWB = Workbooks("SomeWBName")
    Set objWS = objWB.Worksheets("SomeWSName")
    lngLastRow = objWS.Cells(objWS.Rows.Count, "A").End(xlUp).Row   'Find last row with data
    Set rngToLookUp = objWS.Range("A2:D" & lngLastRow)              'set range for last row of data

    arryEmailData = rngToLookUp.Value2    'Get the email data from the sheet into an array

        Set objDict = CreateObject("Scripting.Dictionary")      'set the dicitonary object
        Set objOutlookApp = CreateObject("Outlook.Application") 'set the outlook object


            For i = LBound(arryEmailData, 1) To UBound(arryEmailData, 1)
                varKey = Join(Array(arryEmailData(i, 1), arryEmailData(i, 2)), "|") 'Concatenate columns A and B using '|' as a
                                                                                    'delimiter to form a unique Key

                If Not objDict.Exists(varKey) Then

                    objDict(varKey) = Array(arryEmailData(i, 2), _
                                            arryEmailData(i, 3), _
                                            arryEmailData(i, 4))
                End If

                varKey = Empty

            Next i

            'for each unique key in the dicitonary
            'get the corresponding item which is an array
            'created in the loop above
            On Error GoTo cleanup
            For Each varKey In objDict.Keys
                arryTemp = objDict.Item(varKey)
                Set objOutlookEmail = objOutlookApp.CreateItem(0)
                    With objOutlookEmail
                        .To = arryTemp(0)
                        .Subject = arryTemp(1)
                        .Body = arryTemp(2)
                        .Send
                    End With
                Set objOutlookEmail = Nothing
                arryTemp = Empty
            Next

    MsgBox "All Emails have been sent", vbInformation

cleanup:
        Set objOutlookApp = Nothing
        Application.ScreenUpdating = True

End Sub

Исходное сообщение:

Option Explicit

Public Sub SendEmails()

 Dim objDict As Object
 Dim objWB As Workbook
 Dim objWS As Worksheet
 Dim rngToLookUp As Range
 Dim lngLastRow As Long, i As Long
 Dim arryEmailData As Variant
 Dim objOutlookApp As Object, objOutlookEmail As Object
 Dim varKey As Variant, arryTemp As Variant

    Application.ScreenUpdating = False

    Set objWB = Workbooks("SomeWBName")
    Set objWS = objWB.Worksheets("SomeWSName")
    lngLastRow = objWS.Cells(objWS.Rows.Count, "A").End(xlUp).Row   'Find last row with data
    Set rngToLookUp = objWS.Range("A2:D" & lngLastRow)              'set range for last row of data

    arryEmailData = rngToLookUp.Value2    'Get the email data from the sheet into an array

        Set objDict = CreateObject("Scripting.Dictionary")      'set the dicitonary object
        Set objOutlookApp = CreateObject("Outlook.Application") 'set the outlook object


            For i = LBound(arryEmailData, 1) To UBound(arryEmailData, 1)
                varKey = Join(Array(arryEmailData(i, 1), arryEmailData(i, 2)), "|") 'Concatenate columns A and B using '|' as a
                                                                                    'delimiter to form a unique Key

                If Not objDict.Exists(varKey) Then                          'If the key doesn't already exist, then concatenate
                                                                            'the corresponding Email Address, subject line,
                                                                            'and email body using
                                                                            ''|' as a delimiter
                    objDict(varKey) = Join(Array(arryEmailData(i, 2), _
                                                 arryEmailData(i, 3), _
                                                 arryEmailData(i, 4)), "|")
                End If

                varKey = Empty

            Next i

            'for each unique key in the dicitonary
            'get the corresponding item
            'split the item into a 3 element array using '|' delimiter that
            'was originally used to concatenate the item in the loop above
            On Error GoTo cleanup
            For Each varKey In objDict.Keys
                arryTemp = Split(objDict.Item, "|")
                Set objOutlookEmail = objOutlookApp.CreateItem(0)
                    With objOutlookEmail
                        .To = arryTemp(0)
                        .Subject = arryTemp(1)
                        .Body = arryTemp(2)
                        .Send
                    End With
                Set objOutlookEmail = Nothing
            Next

    MsgBox "All Emails have been sent", vbInformation

cleanup:
        Set objOutlookApp = Nothing
        Application.ScreenUpdating = True

End Sub

Answer 3

Я использую вот так: сначала нужно преобразовать текст в таблицу и назвать его CustomersTbl или использовать

LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' get last row
Set Rng = ws.Range(ws.Cells(1, 1), ws.Cells(LastRow, 4))

вместо

Set rng = ws.Range("CustomersTbl")

Вот код

Sub Send_Row_Or_Rows_2()
' reference Microsoft Scripting Runtime
Dim OutApp As Object, OutMail As Object, dict As Object
Dim tKey(0 To 3, 0 To 1) As Variant
Dim rng As Range
Dim ws As Worksheet

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
    .EnableEvents = False ' speedup Application, disable events
    .ScreenUpdating = False ' prevent flashing, disable screen
End With

Set ws = ThisWorkbook.Worksheets("Sheet1") ' set shortest variable for worksheet
Set dict = CreateObject("Scripting.Dictionary") ' set object for unique values
Set rng = ws.Range("CustomersTbl") ' get range to variable
'LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' get last row
'Set Rng = ws.Range(ws.Cells(1, 1), ws.Cells(LastRow, 4)) 'get range to variable
For Each cRow In rng ' create unique dictionary
    i = i + 1 ' increment
    strCustomer = rng(i, 1)
    strEmail = rng(i, 2)
    strSubj = rng(i, 3)
    strBody = rng(i, 4)
    If dict.Exists(strCustomer) Then ' if dublicate
        Dim tempArr() As Variant
            tempArr() = dict(strCustomer)
                If UBound(tempArr, 2) > 0 Then ' if not nothing
                    If Not IsEmpty(tempArr(0, 1)) Then ' if second element empty
                        sCount = UBound(tempArr, 2) + 1
                    Else
                        sCount = UBound(tempArr, 2)  ' as is empty array
                    End If
                End If
                    ReDim Preserve tempArr(0 To 3, 0 To sCount) ' redim array to next array size
                        tempArr(0, sCount) = strCustomer 'fill array element
                        tempArr(1, sCount) = strEmail 'fill array element
                        tempArr(2, sCount) = strSubj 'fill array element
                        tempArr(3, sCount) = strBody 'fill array element
            dict(strCustomer) = tempArr ' put array to dictionary by unique name
    Else
        tKey(0, 0) = strCustomer 'fill array element
        tKey(1, 0) = strEmail 'fill array element
        tKey(2, 0) = strSubj 'fill array element
        tKey(3, 0) = strBody 'fill array element
            dict.Add strCustomer, tKey ' create unique name
    End If
Next cRow ' loop next row
' now dict contains only unique elements, lets loop throught them
For Each UniqueCustomer In dict ' for each unique element
countEmails = UBound(dict(UniqueCustomer), 2) ' count emails of unique group
    For i = 0 To countEmails ' loop each email in group
        strCustomer = dict(UniqueCustomer)(0, i)
        strEmail = dict(UniqueCustomer)(1, i)
        strSubj = dict(UniqueCustomer)(2, i)
        strBody = dict(UniqueCustomer)(3, i)
        If Not IsEmpty(strCustomer) Then ' if element not empty create email
            Set OutMail = OutApp.CreateItem(0)
                    On Error Resume Next
                    With OutMail
                        .To = strEmail
                        .Subject = strSubj
                        .HTMLBody = strBody
                        .Display  'Or use Send
                    End With
                    On Error GoTo 0
            Set OutMail = Nothing
        Else
            GoTo sNext
        End If
        Stop
sNext:
    Next I ' next email
Next UniqueCustomer 'next unique

cleanup:
Set OutApp = Nothing

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Answer 4

Попробуйте, на самом деле генерируется необходимое количество писем. Если все в порядке, я очищу код

Option Explicit

Sub Send_Row_Or_Rows_2()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim Ash As Worksheet
    Dim Cws As Worksheet
    Dim Rcount As Long
    Dim Rnum As Long
    Dim FilterRange As Range
    Dim FieldNum As Integer


    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    'Set filter sheet, you can also use Sheets("MySheet")
    Set Ash = ActiveSheet

    'Set filter range and filter column (column with e-mail addresses)
    Set FilterRange = Ash.Range("A1:BY" & Ash.Rows.Count)
    FieldNum = 2    'Filter column = B because the filter range start in     Column A
    'FieldNum = 2

    Columns("A:B").Select
    Selection.Copy

    ActiveSheet.Paste

    'Add a worksheet for the unique list and copy the unique list in A1
    Set Cws = Worksheets.Add
    ActiveSheet.Paste
'    FilterRange.Columns(FieldNum).AdvancedFilter _
'            Action:=xlFilterCopy, _
'            CopyToRange:=Cws.Range("A:B"), _
'            CriteriaRange:="", Unique:=True


    Columns("A:B").Select
    Application.CutCopyMode = False
    ActiveSheet.Range("$A$1:$B$10").RemoveDuplicates Columns:=Array(1, 2), Header _
        :=xlYes

    'Count of the unique values + the header cell
    Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

    'If there are unique values start the loop
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount

            'Filter the FilterRange on the FieldNum column
            FilterRange.AutoFilter Field:=1, _
                                   Criteria1:=Cws.Cells(Rnum, 1).Value

            FilterRange.AutoFilter Field:=2, _
                                   Criteria1:=Cws.Cells(Rnum, 2).Value

            'If the unique value is a mail addres create a mail
            If Cws.Cells(Rnum, 2).Value Like "?*@?*.?*" Then

                With Ash.AutoFilter.Range
                    On Error Resume Next
                    Set rng = .SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                End With

                Set OutMail = OutApp.CreateItem(0)

                On Error Resume Next
                With OutMail
                    Debug.Print "to: " & .to & " subj: " & .Subject & " body:" & .htmlbody
                    .to = Cws.Cells(Rnum, 2).Value
                    .Subject = Ash.Cells(Rnum, 3) & " Bond Review " & Date
                    .htmlbody = RangetoHTML(rng)
                    .Display  'Or use Send
                End With
                On Error GoTo 0

                Set OutMail = Nothing
            End If

            'Close AutoFilter
            Ash.AutoFilterMode = False

        Next Rnum
    End If

cleanup:
    Set OutApp = Nothing
    Application.DisplayAlerts = False
    Cws.Delete
    Application.DisplayAlerts = True

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Function RangetoHTML(rng As Range)

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

Public Function EOMonth(dInput As Date)

LastDayOfMonth = DateSerial(Year(dInput()), Month(dInput() + 1), -1)

End Function