如何用VBA为列中涂上代码单元，并将其放入body电子邮件中

Question

i具有以下代码。我希望在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

您可以以下实现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