Refine email range VBA code

[orsm6]

Hi everyone,
I have a code which was found at the Ron DeBruin website that does a lot of what I am hoping to achieve but there are a few things beyond my skills I need some help with.

There are 2 Things I am hoping someone could help with:
1. How can I modify the code below to copy all rows that contain todays date in column C of sheet "SKUData" rather than a range selected by the user? (NOTE: the range of columns to copy will always be A to K on sheet SKUData, but the number of rows to copy will depend on how many rows at the time have today's date in it)
2. How can the code be modified to send an email to the email addresses listed in column J of sheet "Lists" rather than type the email address into the macro code?

I currently have a small macro that sends the email to any address listed in column J, I just do not know how to combine it into this new one.

here is the new code:

Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: 404 Not Found
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    'Set rng = Sheets("YourSheet").Range("D4:D12").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 = "alan.malin@mdlz.com"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng)
        .Send   'or use .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)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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

This is the current email macro

Sub Email()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
 
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(olMailItem)
 
   On Error GoTo cleanup
   For Each cell In Columns("J").Cells.SpecialCells(xlCellTypeConstants)
       If cell.Value Like "?*@?*.?*" And _
        LCase(Cells(cell.Row, "K").Value) = "yes" Then
 
          Set OutMail = OutApp.CreateItem(0)
          On Error Resume Next
            With OutMail
            .To = cell.Value
            .Subject = "Schedule change requires review"
            .HTMLBody = "A schedule change has been implemented. Please check the Production Schedule folder."
                  
            .Send  'Or use Display
            End With
         On Error GoTo 0
         Set OutMail = Nothing
      End If
   Next cell
            
cleanup:
   Set OutApp = Nothing
   Application.ScreenUpdating = True
   
        MsgBox "E-mail successfully sent", 64

End Sub

any help certainly appreciated..... thank you

 

[orsm6]

OK, so thinking about this... rather than make things difficult by trying to isolate and copy data.... if I can hide all rows where column C doesn't contain todays date then my macro will work as I need it.

I tried this macro, but it still shows rows that have dates less than today, not sure what is going on, any thoughts?

Sub HideRowsDate()
    Dim cell    As Range
    
    For Each cell In Range("c1:c1000")
        If cell.Value < Date And cell.Value <> Empty Then cell.EntireRow.Hidden = True
    Next
End Sub

 

[Perpa]

orsm6,
I had seen your post earlier but was busy with other things, and thought someone would have responded before now. If you still need help, then have a look at the red font areas and the 'ListInOneCell' sub I have included.
Perpa

Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: 404 Not Found
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Set rng = Nothing
    On Error Resume Next
'***************************** [COLOR=#ff0000]Answer to 1st Part
LastRow = [A:K].Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row[/COLOR]
[COLOR=#ff0000]    'Only the visible cells in the selection
    'Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want[/COLOR]
[COLOR=#ff0000]    Set rng = Sheets("SKUData").Range("A1:K" & LastRow).SpecialCells(xlCellTypeVisible)[/COLOR]
[COLOR=#ff0000]    Dim cell As Range
    
    For Each cell In Sheets("SKUData").Range("c1:c" & LastRow)
        If cell.Value < Date And cell.Value <> Empty Then cell.EntireRow.Hidden = True
    Next[/COLOR]
'*****************************
    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
'****************************Answer to 2nd Part********
'*
[COLOR=#ff0000]Call ListInOneCell[/COLOR]
'*
'*****************************************************
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = [COLOR=#ff0000]Sheets("List").Cells(1,"J")     'This will give the list of email addresses[/COLOR]
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng)
        .Send   'or use .Display
    End With
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Answer to Part 2:
"2. How can the code be modified to send an email to the email addresses listed in column J of sheet "Lists" rather than type the email address into the macro code?"

Sub ListInOneCell()
'Make  a composite List of All Email Addresses on 'List' in cell J1
    Dim w As Long
    Dim LR As Long
    Dim t As String
    Dim Rng As Range, c As Range
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Sheets("List").Activate
    LR = Range("J2").End(xlDown).Offset(1, 0).Row    'Change J2 to your beginning cell
 
    Set Rng = Range(J2:J" & LR)
    
    'Trim - replaces all multiple spaces with a single one,
    'as well as removes spaces from the left & right of the cell value
        With Rng
            .Value = Application.Trim(.Value)
        End With
    
        For Each c In Rng
            If c <> "" Then
                t = t & c & ";"                    'Note: To add a space after each semicolon use "; "
            Else
                t = Left(t, Len(t) - 1)            'Removes the last semicolon, change the '1' to '2' if the separator is a semicolon and a space
                c.Value = t
                t = ""
            End If
        Next c
[COLOR=#ff0000]    Cells(1, "J") = Cells(LR, "J")  'This is where I put the composite list of email addresses in A1, change to suit[/COLOR]
    [COLOR=#ff0000]Cell[/COLOR][COLOR=#ff0000]s(LR, "J").ClearContents    'I cleared this cell so new email addresses could be added if needed
    Sheets("SKUData").Activate    ' Go back to 'SKUData' worksheet[/COLOR]
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub