Combine 2 RonDeBruin macros - Mail+Attachment+Body - Based on value in A Column

[J0ck3]

Hi there, I've been struggeling with these codes for a while.
I've searched the net, but I can't find any example which does what I need.

Question:
I need a macro that;

Based on value in column A;

1. Macro will find the "TO" E-mail address in Column B (Sheet1),
2. Macro will create 1 mail per new value in A column
3. Macro will find hyperlink to attachment in column C (Sheet1) and attach to e-mail
4. Macro will copy the html body range from another sheet (X)

What I have

Based on value in column A;

1. Macro will find the "TO" E-mail address in Column B (Sheet1),
2. Macro will create 1 mail per new value in A column
3. Macro will find hyperlink to attachment in column C (Sheet1) and attach to e-mail
4. But it takes the same BODY to all the different E-mails.


My code;

Sub Friday_Mail()
'
' Friday_Mail
'
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
'Dim sh2 As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim Rng As Range
'Dim rng2 As Range
    
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Set sh = Sheets("DATA")
    Set sh2 = Sheets("AHUS")

    Set OutApp = CreateObject("Outlook.Application")

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

        'Enter the path/file names in the C:Z column in each row
        Set Rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

    Dim strbody As String
        strbody = "Hi, please see below figures; " & vBline _

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(Rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
        

            With OutMail
                .to = cell.Value
                .Subject = cell.Offset(0, -1).Value
                .HTMLBody = strbody & RangetoHTML(RngX)
                
                For Each FileCell In Rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Display  'Or use Send
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Function RangetoHTML(RngX)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
   Dim fso As Object
   Dim ts As Object
   Dim TempFile As String
   Dim TempWB As Workbook
   Dim cell As Range
   Dim sh As Worksheet
   
   Set sh = Sheets("DATA")
      
   Set Rng1 = ThisWorkbook.Sheets("AHUS").Range("A1:G23")
   Set rng2 = ThisWorkbook.Sheets("GAVLE").Range("A1:G23")
   Set Rng3 = ThisWorkbook.Sheets("HALMSTAD").Range("A1:G23")
   Set Rng4 = ThisWorkbook.Sheets("GOTEBORG").Range("A1:G23")
   Set Rng5 = ThisWorkbook.Sheets("HELSINGBORG").Range("A1:G23")
   Set Rng6 = ThisWorkbook.Sheets("NORRKOPING").Range("A1:G23")
   Set Rng7 = ThisWorkbook.Sheets("STOCKHOLM").Range("A1:G23")
   
    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

    'Enter the path/file names in the C:Z column in each row
    Set Rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
            
      TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
   
   ' Copy the range and create a workbook to receive the data.
    'cell.Offset(0, -1).Value
  
   If cell.Offset(0, -1).Value = "Ahus (SEAHU) Daily Gate" Then
    Rng1.Copy

   ElseIf cell.Offset(0, -1).Value = "Gavle (SEGVX) Daily Gate" Then
    rng2.Copy

   ElseIf cell.Offset(0, -1).Value = "Halmstad (SEHAD) Daily Gate" Then
    Rng3.Copy
      
   ElseIf cell.Offset(0, -1).Value = "Goteborg (SEGOT) Daily Gate" Then
    Rng4.Copy
   
   ElseIf cell.Offset(0, -1).Value = "Helsingborg (SEHEL) Daily Gate" Then
    Rng5.Copy
    
   ElseIf cell.Offset(0, -1).Value = "Norrkoping (SENRK) Daily Gate" Then
    Rng6.Copy
    
   ElseIf cell.Offset(0, -1).Value = "Stockholm (SESTO) Daily Gate" Then
    Rng7.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 an .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 the RangetoHTML subroutine.
   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.
   Kill TempFile

   Set ts = Nothing
   Set fso = Nothing
   Set TempWB = Nothing

   Else
   MsgBox "error"
   End If
   
   Next cell

End Function

In other words, I'm very close - My code creates each mail, and have the correct attachment - but the body is the same in all the different E-mails.
What am I doing wrong? I guess I've overworked the if rules at somehow - and would really appreaciate your assistance.

Any help - changes to current code / new code is highly appreciated since I'm currently stuck..

Thanks in advance

// Joakim