如何在列中着色代码单元并使用VBA放置在正文电子邮件中

Question

我有以下代码。我希望在HTML电子邮件的正文中放置一个表格，我希望负值用红色进行颜色编码，正值用绿色和未更改的值来显示破折号。我可以使它适用于单个单元格引用，但是我无法弄清楚如何合并For Each ... Next命令，以便代码遍历整个列并相应地对所有值进行颜色编码。任何帮助是极大的赞赏。

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

您可以像这样实现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

Answer 2

主要问题是我在.HTMLBody部分使用了rng而不是必须作为函数创建的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