need to avaoid VBA creating a space in between ranges of cells while inserting into outllook email body

[Latha]

Hi, I have the below set of codes.

I have 2 small issues as described below

1. .HTMLBody = StrBody & RangetoHTML(rng1) & RangetoHTML(rng2)
this is inserting a space between rng1 and rng2. (rng1 and rng2 are given in the codes below)

here I want to eliminate the space in between these two range of cells. and it should look like a single table.



2. StrBody = "Dear " & Sheets("AspsByGroup").Cells(i, 3).Value & "<br>" &
"Please find below the Incident Aging report" & "<br><br>"

This is not working for the first email ID provided in cell A2. rest of the emails are fine.

Please help...

Codes I now have :

Sub sendmail()
Dim olapp As Outlook.Application
Dim olmail As Outlook.MailItem
Dim rng1 As Range
Dim rng2 As Range
Dim StrBody As String
Dim LResult As String


For i = 2 To AspsByGroup.Cells(Rows.Count, 1).End(xlUp).Row
Set olapp = New Outlook.Application
Set rng1 = Sheets("AspsByGroup").Range("D1:I1").SpecialCells(xlCellTypeVisible)
Set rng2 = Sheets("AspsByGroup").Range(Cells(i, 4), Cells(i, 10)).SpecialCells(xlCellTypeVisible)
Set olmail = olapp.CreateItem(olMailItem)

With olmail
.To = Cells(i, 1).Value
.CC = Cells(i, 2).Value
.Subject = Cells(i, 3).Value
'Set body format to HTML
.HTMLBody = StrBody & RangetoHTML(rng1) & RangetoHTML(rng2)
StrBody = "Dear " & Sheets("AspsByGroup").Cells(i, 3).Value & "<br>" & _
"Please find below the Incident Aging report" & "<br><br>"
ThisWorkbook.Save
.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
.Display
''.send
End With

Set olmail = Nothing
Set olapp = Nothing
Next

End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
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 xublishsource=", _
"align=left xublishsource=")

'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

 

[RickXL]

Hi,

Try this:

Sub sendmail()
    Dim olapp As Outlook.Application
    Dim olmail As Outlook.MailItem
    Dim rng1 As Range
    Dim rng2 As Range
    Dim StrBody As String
    Dim LResult As String
    Dim i As Long
    
    For i = 2 To AspsByGroup.Cells(Rows.Count, 1).End(xlUp).Row
        Set olapp = New Outlook.Application
        Set rng1 = Sheets("AspsByGroup").Range("D1:I1").SpecialCells(xlCellTypeVisible)
        Set rng2 = Sheets("AspsByGroup").Range(Cells(i, 4), Cells(i, 10)).SpecialCells(xlCellTypeVisible)
        Set olmail = olapp.CreateItem(olMailItem)
        
        With olmail
            .To = Cells(i, 1).Value
            .CC = Cells(i, 2).Value
            .Subject = Cells(i, 3).Value
            'Set body format to HTML
            StrBody = "Dear " & Sheets("AspsByGroup").Cells(i, 3).Value & "<p>" & _
            "Please find below the Incident Aging report" & "<p>"
            .HTMLBody = StrBody & RangetoHTML(rng1, rng2)
            ThisWorkbook.Save
            .Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
            .Display
            ''.send
        End With
        
        Set olmail = Nothing
        Set olapp = Nothing
    Next

End Sub

Function RangetoHTML(rng1 As Range, rng2 As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2013
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim NR As Long  ' Next Aavailable Row
    
    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
    ' Amended to paste two ranges
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        rng1.Copy
        .Cells(1, 1).PasteSpecial Paste:=8
        .Cells(1, 1).PasteSpecial xlPasteValues, , False, False
        .Cells(1, 1).PasteSpecial xlPasteFormats, , False, False
        ' Add second range
        NR = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
        rng2.Copy
        .Cells(NR, 1).PasteSpecial Paste:=8
        .Cells(NR, 1).PasteSpecial xlPasteValues, , False, False
        .Cells(NR, 1).PasteSpecial xlPasteFormats, , False, False
        ' End of add second range
        .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 had to make a couple of changes to Ron de Bruin's function to eliminate the gap between ranges. It now processes two ranges at once.

Also, the reason your string was missing was because you did not set it up before you used it. So I swapped the lines round.
I guessed that some paragraph tags were missing as the forum software has "eaten" them.

 

[Latha]

Thanks a lot... my big headache is now sorted out. thanks a lot

 

[Latha]

and one more please....

I have raw data of the ranges I have mentioned in an another sheet.

I would like the excel to attach a file with only those data which are relevant to the email ID provided in the A column.

For example

In I column there is a Grand total of incidents tickets count. Say 209 tickets are open till today. so I would like the excel to create a new excel file with the name "Ticket details-raw data" and copy paste only those 209 tickets in that and attach it to the email.

Please help me.

Let me know if you need the file to work on so that I can attach it here.

 

[daverunt]

You are running 2 threads on your problems.

http://www.mrexcel.com/forum/excel-...ific-range-cells-specific-group-email-id.html

Nobody wants to waste time answering a thread if it's been solved on another.

 

[Latha]

sorry. but both the threads are raised for different requirements.