Удалите ненужные линии из ячеек при использовании Ron de Bruin 'Range to HTML'

Question

Я изменил код Рона де Брюина для Диапазон почты / Выбор в теле письма (Диапазон Excel до HTML Outlook) для моих нужд. Код Рона можно найти здесь: https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

См. Это изображение:

Диапазон в рабочем листе разрабатывается из входных данных, предоставленных пользователем в UserForm . Столбец «Комментарии» содержит комментарии, введенные пользователем, которые могут занимать несколько строк. Например, D8 содержит комментарии, введенные пользователем в TextBox в UserForm . Чтобы ввести комментарии в новой строке, пользователь использовал Shift + Enter в TextBox .

Теперь все выглядит хорошо в Excel ( D8 ). Но после использования процедуры Рона для преобразования этого диапазона в HTML и отображения в теле электронной почты Outlook, дополнительная строка добавляется между каждым комментарием.

Как мне предотвратить это или удалить эти ненужные дополнительные строки?

Примечание: Я не сильно изменил код Рона. Я использовал его как есть, за исключением незначительных настроек и выбора диапазона от A1 до D N , где N - последняя строка данные (в данном случае 8).

Код

Sub SendReport(shtname As String, nrows As Long, name As String)

Dim sht As Worksheet, wsdata As Worksheet
Dim sendrng As Range, rngdata As Range

'Set data sheet
Set wsdata = ThisWorkbook.Worksheets("Data")
Set rngdata = wsdata.Range("A2").CurrentRegion
Set sht = ThisWorkbook.Sheets(shtname)

'Select range to send
Set sendrng = Nothing
On Error Resume Next
Set sendrng = sht.Range("A1:D" & 6 + nrows)
On Error GoTo 0
If sendrng Is Nothing Then
    msg = MsgBox("Invalid selection or protected sheet!" & vbCrLf & _ 
    "Please correct and try again.", vbOKOnly + vbCritical, "Email Report")
    Exit Sub
End If

Application.EnableEvents = False
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

'Email To and CC details
emailcc = ""
factory = Application.WorksheetFunction.VLookup(name, rngdata, 2, False)
If factory = "Gas" Then
    emailto = wsdata.Range("K7").Value
ElseIf factory = "Electricity" Then
    emailto = wsdata.Range("K8").Value
End If

'Email, RangetoHTML
On Error Resume Next
With OutMail
    .To = emailto
    .CC = emailcc
    .BCC = ""
    .Subject = "Report: " & sht.Range("4").Value & ", " & 
sht.Range("B4").Value
    .HTMLBody = RangetoHTML(sendrng)
    .Display
    '.Send
End With
On Error GoTo 0

Application.EnableEvents = True
Application.ScreenUpdating = True
Set OutMail = Nothing
Set OutApp = Nothing

'Confirm send to user
msg = MsgBox("Report sent through Outlook. Check 'Sent Items'.", _ 
vbOKOnly + vbInformation, "Email Report")

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 paste 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

Редактировать: 01 мая 2020

Я заметил, что проблема возникает только в ячейках, где линия почти достигает всей ширины ячейки. Я использовал Range.AutoFit для всех столбцов, затем установил ширину для B, C и D. Это код, который я использую для форматирования:

'Final formatting
sht.Range("A1:D" & 6 + nrows).Font.Size = 10
sht.Range("A1:D" & 6 + nrows).Font.Name = "Arial"
sht.Columns("A:D").AutoFit
sht.Columns("B").ColumnWidth = 18
sht.Columns("C").ColumnWidth = 18
sht.Columns("D").ColumnWidth = 80
sht.Range("D7:D" & 6 + nrows).WrapText = True
sht.Range("A1").Select

Может ли это быть причиной проблемы?

Редактировать: 05 мая 2020

По предложению @ teylyn, я скопировал таблицу и включил невидимые символы в Word. В конце каждой строки появляется дополнительный символ возврата каретки. Как мне удалить их?