VBA: Why when I paste cells in a email using VBA does it remove some conditional formatting?

Question

What I want to be able to do is copy and paste cells from a spread sheet into an email with all the conditional formatting applied. For example, say I have the following cells:

    A                      B            C
 1  Name:                  Sales:       Percentage
 2  Dave Grohl             3            80%
 3  Kurt Cobain            6            40%
 4  Pat Smear              7            66%
 5  Freddie Mercury        2            25%
 6  Roger Taylor           8            95%
 7  Brian May              1            74%
 8  Taylor Hawkins         0            32%
 9  Noel Gallagher         9            63%
10  Michael Jackson        8            30%
11  Whitney Houston        2            82%

And there was conditional formatting on column B (Sales) where anything > 5 was green and anything <= 5 was red and conditional formatting on column C (Percentage) where anything >50% was green and <= 50% is red, what happens is it keeps the values but removes some of the formatting, e.g. removes the chosen font on the data but not the headings and removes the color of the Sales column but not the Percentage column.

The code I am using is as follows:

Sub EmailExtract()

Dim objOutlook As Object
Dim objMail As Object
Dim TempFilePath As String
Dim Location As String
Dim Individual As String
Dim rng As Range

Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Worksheets("Contacts").Activate
Range("A2").Select
While ActiveCell <> ""

    ActiveCell.Offset(1, 0).Select
    Location = ActiveCell.Address
    Individual = ActiveCell.Value
    Worksheets("Individual Output 2").Activate
    Range("C2").Value = Individual

    Set rng = ActiveSheet.Range("A1:M28").Rows.SpecialCells(xlCellTypeVisible)
    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 objMail
            .To = "joe.bloggs@hotmail.com"
            .Subject = ""

            Dim Greeting As String
            If Time >= #12:00:00 PM# Then
                Greeting = "Afternoon ,"
            Else
                Greeting = "Morning,"
            End If



            .HTMLBODY = "" & "Good " + Greeting + ""
            .HTMLBODY = .HTMLBODY + "" & "Please find below your " & MonthName((Month(Date)) - 1) & " Information." & ""
            .HTMLBODY = .HTMLBODY + RangetoHTML(rng)
            .HTMLBODY = .HTMLBODY + "" & "Kind Regards" & ""
            .HTMLBODY = .HTMLBODY + "" & "Joe Bloggs" & ""
            .Display
    End With
    Worksheets("Contacts").Activate
Wend

Set objOutlook = Nothing
Set objMail = Nothing

Set objOutlook = Nothing
Set objMail = 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 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

I have tried changing the following:

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

To:

Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
    .Cells(1).PasteSpecial
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
End With

And to:

Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
    rng.Copy Destination:=.Cells(1)
    .Cells(1).Select
    On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
    On Error GoTo 0
End With

But neither of them have worked.

Can someone please help?

I've found out what the problem is but how I can get round it:

The conditional formatting is applied on workbook A, what the code does is copy the range from workbook A to workbook B, on workbook A some of the conditional formatting is calculated using data on other sheets within workbook A, when this is copied over the conditional formatting for the cells that are using data in other sheets are no longer formatted because the links break. So what I need is for it to work in a way that copies the conditional formatting, removes the conditional formatting but keeps the colors, copies and pastes the cells into workbook B, then reapplies the conditional formatting in workbook A for next time. Any ideas?

VBA: Why when I paste cells in a email using VBA does it remove some conditional formatting?

Answers (1)

Related Questions