Macro - Range offset based on row

[StevenAncel]

I have a macro which sends out emails.

It currently works perfect, there is just one factor i need to have fixed in order to work how i want.

the sheet is set up like this.

	A	B	C	D	E
	Subject	To	CC	BCC	File
1	Subject #1	Steven.ancel@live.com	Steven.ancel@live.com	Steven.ancel@live.com	December 2015\Completion Reports 12-07\Completion Report_12-07_AM3.xlsx
2	Subject #2	Steven.ancel@live.com	Steven.ancel@live.com	Steven.ancel@live.com	December 2015\Completion Reports 12-07\Completion Report_12-07_CYD.xlsx

<tbody>
</tbody>

Sub Email_Sender()'
'
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim att As Range
    Dim rng As Range
    Dim wb1 As Excel.Workbook
    Dim strPath As String
    Dim wkbkSource As Workbook


    
    strPath = "T:\Store your files\INSTALLATIONS REPORTS\Completion Reports\"
    


    Set sh = Sheets("Sheet1")


    Set OutApp = CreateObject("Outlook.Application")
    
    Set wkbkSource = Workbooks.Open(strPath & Range("E2").Value)
    


    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)


        'Enter the path/file names in the C:Z column in each row
        Set att = sh.Cells(cell.Row, 1).Range("E1:Z1")
        Set rng = ActiveWorkbook.Sheets("Breakdown").Range("a2:i81").SpecialCells(xlCellTypeVisible)
        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)


            With OutMail
                .to = cell.Value
                .cc = cell.Offset(0, 1).Value
                .bcc = cell.Offset(0, 2).Value
                .Subject = "COMPLETION REPORT " & cell.Offset(0, -1).Value
                .HTMLBody = "Good Afternoon, 
 
Please see the Completion Report for " & cell.Offset(0, -1).Value & RangetoHTML(rng)
                For Each FileCell In att.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(strPath & FileCell.Value) <> "" Then
                            .Attachments.Add strPath & FileCell.Value
                        End If
                    End If
                Next FileCell


                .Send 'Or use .Display to show the message before sending
            End With


            Set OutMail = Nothing
        End If
    Next cell


    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Application.DisplayAlerts = False
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
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

The part i need to fix, is below

Set wkbkSource = Workbooks.Open(strPath & Range("E2").Value)

Instead of the range being defined as specific range "E2" i need it to basically offset where it chooses the file in whatever e# is lined up with that 'Email'

 

[daverunt]

Hi,

As I see it you could use ActiveCell.Offset( x,x) in this situation
or explain a little better what this means:

"I need it to basically offset where it chooses the file in whatever e# is lined up with that 'Email' "

 

[StevenAncel]

This is how it works.

It makes an email using the info in 'row 1' ----- thats where E2 comes in

i need it to continue to do the other rows:
Make an email using the info in 'row 2' ----- i need it to auto use E3 on this one

and so forth and so on.

 

[daverunt]

Ok so you want create a mail for each occupied row.
I have used column E as that's the one with the documents to open and the one you were using.
If it gets to an empty cell it will stop.

Sub Email_Sender()'
'
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim att As Range
    Dim rng As Range
    Dim wb1 As Excel.Workbook
    Dim strPath As String
    Dim wkbkSource As Workbook


    
    strPath = "T:\Store your files\INSTALLATIONS REPORTS\Completion Reports\"
    


    Set sh = Sheets("Sheet1")


    Set OutApp = CreateObject("Outlook.Application")

'Loop down column E until it meets an empty cell
    
     Set rng = Range(Range("E2"), Range("E" & Rows.Count).End(xlUp))
     For Each eRow In rng
         If eRow.Value <> "" Then
    
    Set wkbkSource = Workbooks.Open(strPath & eRow.Value)    


    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)


        'Enter the path/file names in the C:Z column in each row
        Set att = sh.Cells(cell.Row, 1).Range("E1:Z1")
        Set rng = ActiveWorkbook.Sheets("Breakdown").Range("a2:i81").SpecialCells(xlCellTypeVisible)
        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)


            With OutMail
                .to = cell.Value
                .cc = cell.Offset(0, 1).Value
                .bcc = cell.Offset(0, 2).Value
                .Subject = "COMPLETION REPORT " & cell.Offset(0, -1).Value
                .HTMLBody = "Good Afternoon, 
 
Please see the Completion Report for " & cell.Offset(0, -1).Value & RangetoHTML(rng)
                For Each FileCell In att.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(strPath & FileCell.Value) <> "" Then
                            .Attachments.Add strPath & FileCell.Value
                        End If
                    End If
                Next FileCell


                .Send 'Or use .Display to show the message before sending
            End With


            Set OutMail = Nothing
        End If
    Next cell


    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Application.DisplayAlerts = False
    ActiveWorkbook.Close
    Application.DisplayAlerts = True

End If
Next

End Sub

 

[StevenAncel]

the line below appears in red


Please see the Completion Report for " & cell.Offset(0, -1).Value & RangetoHTML(rng)

 

[StevenAncel]

Nevermind, I figured that part out.

An error comes up on this line
" Set OutMail = OutApp.CreateItem(0)"