Как раскрасить ячейки кода в столбцах и разместить их в теле письма с помощью VBA

Question

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

Sub Test()
Dim oApp As Object
Dim oEmail As Object


Set oApp = CreateObject("Outlook.Application")
Set oEmail = oApp.CreateItem(0)

rng = Range("A1")

If Range("A1") < 0 Then
rng = "<font color=""red"">" & "<b>" & rng & "</font>" & "</b>"
ElseIf Range("A1") > 0 Then
rng = "<font color=""green"">" & "<b>" & rng & "</font>" & "</b>"
Else: rng = "<b>" & "-" & "</b>"
End If


Set oApp = CreateObject("Outlook.Application")
Set oEmail = oApp.CreateItem(olMailItem)

oEmail.Close olSave
oEmail.Save
oEmail.BCC = ""
oEmail.Subject = "Test"
oEmail.SentOnBehalfOfName = """Hello"" <xxx@xxx>"
oEmail.HTMLBody = rng
oEmail.Display

Set oEmail = Nothing
Set oApp = Nothing
Set colAttach = Nothing
Set oAttach = Nothing

cleanup:
Set oApp = Nothing

End Sub

Answer 1

Основная проблема заключалась в том, что я использовал rng в разделе .HTMLBody вместо RangetoHTML (rng), который должен был быть создан как функция.Код ниже.

Sub Test()
Dim oApp As Object
Dim oEmail As Object
Dim ws As Worksheet
Dim myCell As Range
Dim rng As Range

Set oApp = CreateObject("Outlook.Application")
Set oEmail = oApp.CreateItem(0)

Set ws = ThisWorkbook.Sheets("Sheet1")
Set rng = Sheets("Sheet1").Range("A1:A10, "A12:A17"")

For Each myCell In rng
If myCell < 0 Then
myCell.Font.Color = vbRed
ElseIf myCell > 0 Then
myCell.Font.Color = vbGreen
Else: myCell.Font.Color = vbBlack
End If
Next myCell

Set oApp = CreateObject("Outlook.Application")
Set oEmail = oApp.CreateItem(olMailItem)

oEmail.BCC = ""
oEmail.Subject = "Test"
oEmail.SentOnBehalfOfName = """FBN Markets"" <xxx@xxx>"
oEmail.HTMLBody = RangetoHTML(rng)
oEmail.Send

Set oEmail = Nothing
Set oApp = Nothing
Set colAttach = Nothing
Set oAttach = Nothing

cleanup:
Set oApp = Nothing

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"

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


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

Answer 2

Вы можете реализовать цикл For Each следующим образом:

---

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<-- Update
Dim myCell As Range, rng As Range

Set rng = ws.Range("A1:A10", "A12:A17")

For Each myCell In rng
    If myCell < 0 Then
        myCell.[Format]
    ElseIf myCell > 0 Then
        myCell.[Format]
    Else
        myCell.[Format]
    End If
Next myCell