VBA auto email

[Shneederling]

Hi all,

We have a tracker for stock waiting to be booked in. When our warehouse has booked in the stock, they enter 'Closed' into a particular cell, add a comment, and the line turns blue. How can I set the spreadsheet up so when the warehouse enter 'Closed', an email is created with the comment added and automatically sent to the person who originally added the line?

 

[SpillerBD]

Check Ron Debruin for some email code.
However, your flow of the process will have the email sent before any comment is entered. Be careful as to what and when the email will be created by the macro. You will probably just call the email macro once all required cells have met a condition or a separate cell is indicated for "ready for Email"

 

[Logit]

.
Which cell do they enter CLOSED ? Is it a single cell for all deliveries or is it a column of cells ?

Which line turns blue ?

How can you determine who entered the line .. where is the email going ?

 

[Shneederling]

.
Which cell do they enter CLOSED ? Is it a single cell for all deliveries or is it a column of cells ?

Which line turns blue ?

How can you determine who entered the line .. where is the email going ?

It is a column of cells where closed will be entered.
On the row the word closed is entered, it uses conditional formatting to turn it blue.
We enter our names when we add a line, but obviously we will need to enter our email address instead so it can be picked up

 

[Logit]

.
Great !

Final questions : What column has the word CLOSED ? What column has the email address ? What row do the entries begin with ? (what is the first possible row where CLOSED would be entered ?)

 

[Shneederling]

.
Great !

Final questions : What column has the word CLOSED ? What column has the email address ? What row do the entries begin with ? (what is the first possible row where CLOSED would be entered ?)

Column N will have the word Closed.
Receiver email address will be in column D, sender email address will be in column M.
Entries begin on line 3.

Many thank for looking into this for me

 

[Logit]

.
I have the workbook code complete. Few things I need to understand in order for the macros to function correctly.

If you are familiar with macros I can simply forward the code and you can edit a few lines on your own to insure the code matches
the workbook there.

If you are not comfortable doing that ... the sheet where CLOSED is entered in Column M ... what is the sheet number ?

In that same workbook, is Sheet2 empty and not used for anything ? If not, what sheet is ?

 

[Shneederling]

.
I have the workbook code complete. Few things I need to understand in order for the macros to function correctly.

If you are familiar with macros I can simply forward the code and you can edit a few lines on your own to insure the code matches
the workbook there.

If you are not comfortable doing that ... the sheet where CLOSED is entered in Column M ... what is the sheet number ?

In that same workbook, is Sheet2 empty and not used for anything ? If not, what sheet is ?

That's awesome, many thanks for this.

I have some knowledge regarding editing macros. If can send over, I will try and learn what will need editing. The more I learn, the better

 

[Logit]

.
Download workbook : https://www.amazon.com/clouddrive/share/2OyHJvx6JAUBiaBTEEMilOMWKEO1TkxcDwJtyjEbPvT

The following is the majority of the code. There is other code in the worksheet module as well.

Option Explicit


Sub CopyRowsAcross()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")


For i = 3 To ws1.Range("N65536").End(xlUp).Row


    If ws1.Cells(i, 14) = "Closed" And ws1.Cells(i, 15) = "" Then
        ws1.Cells(i, 15) = " " & Now()
        ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1)
        Mail_Selection_Range_Outlook_Body
        ws2.Rows.Delete
    End If
    
Next i


End Sub


Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = Sheets("Sheet2").Range("A2:O2" & lEndRow).SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .To = Sheets("Sheet2").Range("D2").Value
    .CC = ""
    .BCC = ""
    .Subject = "New Inventory Arrival"


    .HTMLBody = "Greetings :" & "<br><br>" & "<p>Text above Excel cells" & "<br><br>" & _
                RangetoHTML(rng) & "<br><br>" & _
                "Text below Excel cells.</p>"
    
    ' In place of the following statement, you can use ".Send" to
    ' send the e-mail message without first viewing
    .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)
    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

 

[Shneederling]

.
Download workbook : https://www.amazon.com/clouddrive/share/2OyHJvx6JAUBiaBTEEMilOMWKEO1TkxcDwJtyjEbPvT

The following is the majority of the code. There is other code in the worksheet module as well.

Option Explicit


Sub CopyRowsAcross()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")


For i = 3 To ws1.Range("N65536").End(xlUp).Row


    If ws1.Cells(i, 14) = "Closed" And ws1.Cells(i, 15) = "" Then
        ws1.Cells(i, 15) = " " & Now()
        ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1)
        Mail_Selection_Range_Outlook_Body
        ws2.Rows.Delete
    End If
    
Next i


End Sub


Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = Sheets("Sheet2").Range("A2:O2" & lEndRow).SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .To = Sheets("Sheet2").Range("D2").Value
    .CC = ""
    .BCC = ""
    .Subject = "New Inventory Arrival"


    .HTMLBody = "Greetings :" & "

" & "Text above Excel cells" & "

" & _
                RangetoHTML(rng) & "

" & _
                "Text below Excel cells.
"
    
    ' In place of the following statement, you can use ".Send" to
    ' send the e-mail message without first viewing
    .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)
    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

Amazing!! huge thanks for this. I have now amended to suit