VBA to email skipping balnk lines or totals = 0

shophoney

Active Member
Joined
Jun 16, 2014
Messages
281
Hi, below is my VBA macro for emailing a worksheet. But I would like to hide any blank lines or lines where the value = 0.

Is there a way. My email is already 400 lines and I send it to all staff daily for a recap.

Sub CDO_MGMTdss()
Dim rng As Range
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")


iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "xxxxxx@gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "xxxxxx"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With

Set rng = Nothing
On Error Resume Next

'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'Set rng = Sheets("Sheet1").Range("A1:J35").SpecialCells(xlCellTypeVisible)
Set rng = Sheets("DSS MGMT").Range("A1:G499")
'Set rng = ActiveSheet.UsedRange

On Error GoTo 0

If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

With iMsg
Set .Configuration = iConf
.To = "STEVEN@xxxx.COM"
'.To = ActiveSheet.Range("AA2").Value
'.To = Sheets("EMAIL NAMES").Range("G5").value
'''.CC = "xx@sxxxx.com"
'.BCC = ActiveSheet.Range("B128").Value
.From = """No_reply"" <No_reply@sxxy.com>"
.Subject = ActiveSheet.Range("B1").Value
.HTMLBody = RangetoHTML(rng)
.Send
End With

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

On Error Resume Next

If Err.Number <> 0 Then
MsgBox Err.Description, vbCritical, "There was an error"
Exit Sub
End If

Sheets("MGMT DSS").Select
Range("E123:H135").Select
Selection.ClearContents
'''Range("E123:E135").Select
'''Selection.ClearContents
'''Range("A221:H221").Select
'''Selection.ClearContents
'''Range("C226:H226").Select
'''Selection.ClearContents

ActiveSheet.Protect
MsgBox ("EMAIL HAS BEEN SENT!")

'MsgBox "The DSS has been emailed!", vbExclamation, , "Sent"
'MsgBox "PLEASE CLOSE ALL PROGRAMS !", vbExclamation, , "IMPORTANT"


End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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 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
 

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
Update this function:
Change D for the column to review

Code:
Function [COLOR=#0000ff]RangetoHTML[/COLOR](rng As Range)
  ' Changed by Ron de Bruin 28-Oct-2006
  ' Working in Office 2000-2016
  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 Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
[COLOR=#0000ff]    Dim i As Long[/COLOR]
[COLOR=#0000ff]    For i = rng.Rows.Count To 1 Step -1[/COLOR]
[COLOR=#0000ff]      If .Cells(i, "[/COLOR][COLOR=#ff0000]D[/COLOR][COLOR=#0000ff]").Value = "" Or .Cells(i, "[/COLOR][COLOR=#ff0000]D[/COLOR][COLOR=#0000ff]").Value = 0 Then[/COLOR]
[COLOR=#0000ff]        .Rows(i).Delete[/COLOR]
[COLOR=#0000ff]      End If[/COLOR]
[COLOR=#0000ff]    Next[/COLOR]
    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
 
Upvote 0
wow, that is great.

Thanks a ton. I've tried to resolve this for years.

Quick question. My screen doesn't update now till i move from tab to tab. I think I have something wrong in the code and when I change or type something it wont display to i jump from tab to tab.

If that makes sense.

If I use a slicer to pick something I have to switch tabs to see the change.
 
Upvote 0
Quick question. My screen doesn't update now till i move from tab to tab. I think I have something wrong in the code and when I change or type something it wont display to i jump from tab to tab.

I see everything well in your code, but in this part add the following line:

Code:
With Application
.EnableEvents = True
.ScreenUpdating = True
[COLOR=#0000ff].Calculation = xlCalculationAutomatic[/COLOR]
End With
 
Upvote 0
Hi, i think that resolved it.

I really want to thank you for that code. It will make things look so much better than send 500 lines when only 200 are valid.

Cheers.
 
Upvote 0
Im glad to help you, thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,531
Messages
6,114,172
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top