I have code to select a specified range and paste it into an e-mail. I would like to skip copying blank cells and paste only the cells that contain data.
The range should stay the same as it is a table filled from external sources. Sometimes cells might be blank and at other times different cells will be blank. At times no cells will be blank.
I tried constants. It would then only paste the range C13:J13. This is the only row that hasn't any formulae in the cells, only text. All other cells within the range have formulae. I guess it would be best to check whether length <1 then skip.
Sub PrepareMailOffer()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("000000").Range("C12:J29").SpecialCells(xlCellTypeVisible)
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
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Range("N4").Value
.CC = ""
.BCC = ""
.Subject = ""
.HTMLBody = "" & _
RangetoHTML(rng) & _
"" & _
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = 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"
'Copy the range and create a new workbook to paste 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
The code works when I have no blank cells.
Please, try the next adapted code, which hides the blank rows (even with blank from formula) and process the visible cells of resulted range:
Sub PrepareMailOffer()
Dim ws As Worksheet, rng As Range, rngH As Range, i As Long
Dim OutApp As Object, OutMail As Object
Set ws = Sheets("000000")
Set rng = ws.Range("C12:J29")
'place the blank rows in a Union range and hide them, at once:
For i = 1 To rng.rows.count
If WorksheetFunction.CountBlank(rng.rows(i)) = rng.Columns.count Then
addToRange rngH, rng.rows(i).EntireRow
End If
Next i
If Not rngH Is Nothing Then rngH.EntireRow.Hidden = True 'hide the blank rows
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Range("N4").Value
.cc = ""
.BCC = ""
.Subject = ""
.HTMLBody = "" & _
RangetoHTML(rng.SpecialCells(xlCellTypeVisible)) & _
"" & _
.Display
End With
If Not rngH Is Nothing Then rngH.EntireRow.Hidden = False 'unhide the previous hidden rows
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Sub addToRange(rngU As Range, rng As Range)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
On Error Resume Next
in your code context only do not let you know what error you have, if any...
You should use the same (existing) RangetoHTML
function...
Please, send some feedback after testing it.