Link to home
Start Free TrialLog in
Avatar of bsharath
bsharathFlag for India

asked on

Script that creates an email. Need help in removing a particular word that comes in.

Hi,

Script that creates an email. Need help in removing a particular word that comes in.
As per screenshot. The word that i have underlined is what i dont want in the body of the email.
Can anyone help me remove that word.

regards
Sharath
Option Explicit
 
Sub Send_Mail()

    Dim rng1 As Range, rng2 As Range, rng3 As Range
    Dim cel As Range
    Dim MyDic As Object
    Dim doit, FirstAddress As String
    Set MyDic = CreateObject("Scripting.Dictionary")
 
    Sheets("DCS").Select
    Set rng1 = Sheets("DCS").Range([k3], Cells(ActiveSheet.Rows.Count, "k").End(xlUp)).SpecialCells(xlConstants)
    For Each cel In rng1
        Set rng3 = Nothing
        If cel.Value <> vbNullString And cel.Offset(0, 7) = "" Then
            If Not MyDic.Exists(cel.Value) Then
                Set rng2 = rng1.Find(cel.Value, rng1.Cells(1), xlValues, xlWhole, xlByRows, xlPrevious)
                If Not rng2 Is Nothing Then
                    Set rng3 = Cells(rng2.row, "q")
                    FirstAddress = rng2.Address
                    Do
                        Set rng2 = rng1.FindNext(rng2)
                        Set rng3 = Union(rng3, Cells(rng2.row, "q"))
                    Loop While FirstAddress <> rng2.Address
                End If
                MyDic.Add cel.Value, cel.row
Mailem rng3
            Else
            End If
        End If
 
    Next
End Sub
 
Sub Mailem(ByVal rng3 As Range)
Dim outApp, outMail
Dim strFooter As String, strHeader As String
Dim c As Range, strBody As String
 
strBody = "Hi " & Left(Cells(rng3.Cells(1).Row, "O").Value, InStr(Cells(rng3.Cells(1).Row, "O").Value, ".") - 1) & ",<br><br> The for each DCS."
strBody = strBody & "<br><br>" & Cells(2, rng3.Column).Value & "<br><table border=1><tr><td><B>Type</B></td><td><b>Machine name</b></td></tr>"
For Each c In rng3
    If Cells(c.Row, "R") = "" Then
        strBody = strBody & IIf(c.Value = "", "<font color=""#FF0000"">(Please fill in the blank)</font>", "<tr><td align=center>" & c.Value & "</td><td align=center>" & c.Offset(, -1).Value) & "</td></tr>"
    End If
Next c
strBody = strBody & "</table><br><br><br>Regards, <br>Sharath"
 
Set outApp = CreateObject("Outlook.Application")
outApp.Session.Logon
Set outMail = outApp.CreateItem(0)
With outMail
    .To = Cells(rng3.Cells(1).Row, "O").Value
    .SentOnBehalfOfName = "Information Request<sha@plc.com>"
    .CC = "sha@plc.com;Muruiei@plc.com"
    .Subject = "DCS"
    .HTMLBody = strBody
    .Recipients.ResolveAll
    .Display
End With
Set outMail = Nothing
Set outApp = Nothing
End Sub

Open in new window

Capture1111.JPG
Avatar of Brendan M
Brendan M
Flag of Australia image

Option Explicit
 
Sub Send_Mail()

    Dim rng1 As Range, rng2 As Range, rng3 As Range
    Dim cel As Range
    Dim MyDic As Object
    Dim doit, FirstAddress As String
    Set MyDic = CreateObject("Scripting.Dictionary")
 
    Sheets("DCS").Select
    Set rng1 = Sheets("DCS").Range([k3], Cells(ActiveSheet.Rows.Count, "k").End(xlUp)).SpecialCells(xlConstants)
    For Each cel In rng1
        Set rng3 = Nothing
        If cel.Value <> vbNullString And cel.Offset(0, 7) = "" Then
            If Not MyDic.Exists(cel.Value) Then
                Set rng2 = rng1.Find(cel.Value, rng1.Cells(1), xlValues, xlWhole, xlByRows, xlPrevious)
                If Not rng2 Is Nothing Then
                    Set rng3 = Cells(rng2.row, "q")
                    FirstAddress = rng2.Address
                    Do
                        Set rng2 = rng1.FindNext(rng2)
                        Set rng3 = Union(rng3, Cells(rng2.row, "q"))
                    Loop While FirstAddress <> rng2.Address
                End If
                MyDic.Add cel.Value, cel.row
Mailem rng3
            Else
            End If
        End If
 
    Next
End Sub
 
Sub Mailem(ByVal rng3 As Range)
Dim outApp, outMail
Dim strFooter As String, strHeader As String
Dim c As Range, strBody As String
 
strBody = "Hi " & Left(Cells(rng3.Cells(1).Row, "O").Value, InStr(Cells(rng3.Cells(1).Row, "O").Value, ".") - 1) & ",<br><br> The for each DCS."
strBody = strBody & "<br><br>" & Cells(2, rng3.Column).Value & "<br><table border=1><tr><td><B>Type</B></td></tr>"
For Each c In rng3
    If Cells(c.Row, "R") = "" Then
        strBody = strBody & IIf(c.Value = "", "<font color=""#FF0000"">(Please fill in the blank)</font>", "<tr><td align=center>" & c.Value & "</td><td align=center>" & c.Offset(, -1).Value) & "</td></tr>"
    End If
Next c
strBody = strBody & "</table><br><br><br>Regards, <br>Sharath"
 
Set outApp = CreateObject("Outlook.Application")
outApp.Session.Logon
Set outMail = outApp.CreateItem(0)
With outMail
    .To = Cells(rng3.Cells(1).Row, "O").Value
    .SentOnBehalfOfName = "Information Request<sha@plc.com>"
    .CC = "sha@plc.com;Muruiei@plc.com"
    .Subject = "DCS"
    .HTMLBody = strBody
    .Recipients.ResolveAll
    .Display
End With
Set outMail = Nothing
Set outApp = Nothing
End Sub

Open in new window

Avatar of Brendan M
Brendan M
Flag of Australia image
sorry wrong one

possibly remove
" & Cells(2, rng3.Column).Value & "

including the quotes

so line 41 becomes
strBody = strBody & "


TypeMachine name"
Option Explicit
 
Sub Send_Mail()

    Dim rng1 As Range, rng2 As Range, rng3 As Range
    Dim cel As Range
    Dim MyDic As Object
    Dim doit, FirstAddress As String
    Set MyDic = CreateObject("Scripting.Dictionary")
 
    Sheets("DCS").Select
    Set rng1 = Sheets("DCS").Range([k3], Cells(ActiveSheet.Rows.Count, "k").End(xlUp)).SpecialCells(xlConstants)
    For Each cel In rng1
        Set rng3 = Nothing
        If cel.Value <> vbNullString And cel.Offset(0, 7) = "" Then
            If Not MyDic.Exists(cel.Value) Then
                Set rng2 = rng1.Find(cel.Value, rng1.Cells(1), xlValues, xlWhole, xlByRows, xlPrevious)
                If Not rng2 Is Nothing Then
                    Set rng3 = Cells(rng2.row, "q")
                    FirstAddress = rng2.Address
                    Do
                        Set rng2 = rng1.FindNext(rng2)
                        Set rng3 = Union(rng3, Cells(rng2.row, "q"))
                    Loop While FirstAddress <> rng2.Address
                End If
                MyDic.Add cel.Value, cel.row
Mailem rng3
            Else
            End If
        End If
 
    Next
End Sub
 
Sub Mailem(ByVal rng3 As Range)
Dim outApp, outMail
Dim strFooter As String, strHeader As String
Dim c As Range, strBody As String
 
strBody = "Hi " & Left(Cells(rng3.Cells(1).Row, "O").Value, InStr(Cells(rng3.Cells(1).Row, "O").Value, ".") - 1) & ",<br><br> The for each DCS."
strBody = strBody & "<br><br>" & Cells(2, rng3.Column).Value & "<br><table border=1><tr><td><B>Type</B></td><td><b>Machine name</b></td></tr>"
For Each c In rng3
    If Cells(c.Row, "R") = "" Then
        strBody = strBody & IIf(c.Value = "", "<font color=""#FF0000"">(Please fill in the blank)</font>", "<tr><td align=center>" & c.Value & "</td><td align=center>" & c.Offset(, -1).Value) & "</td></tr>"
    End If
Next c
strBody = strBody & "</table><br><br><br>Regards, <br>Sharath"
 
Set outApp = CreateObject("Outlook.Application")
outApp.Session.Logon
Set outMail = outApp.CreateItem(0)
With outMail
    .To = Cells(rng3.Cells(1).Row, "O").Value
    .SentOnBehalfOfName = "Information Request<sha@plc.com>"
    .CC = "sha@plc.com;Muruiei@plc.com"
    .Subject = "DCS"
    .HTMLBody = strBody
    .Recipients.ResolveAll
    .Display
End With
Set outMail = Nothing
Set outApp = Nothing
End Sub

Open in new window

Avatar of bsharath
bsharath
Flag of India image

ASKER

Still dont get it right
Type has to come above DCS and Machine name above DEV22
Capture1111.JPG
Avatar of bsharath
bsharath
Flag of India image

ASKER

For the 2nd code i get this
Its as the first one only
Capture1111.JPG
Avatar of RobSampson
RobSampson
Flag of Australia image
If you change this line:
strBody = strBody & "<br><br>" & Cells(2, rng3.Column).Value & "<br><table border=1><tr><td><B>Type</B></td><td><b>Machine name</b></td></tr>"

to this
strBody = strBody & "<br><br><table border=1><tr><td><B>Type</B></td><td><b>Machine name</b></td></tr>"

Does that help?

Rob.
Avatar of bsharath
bsharath
Flag of India image

ASKER

Rob its perfect now
One addition another table next to it as shown in 2nd screenshot
As-now.JPG
To-be-as.JPG
Avatar of RobSampson
RobSampson
Flag of Australia image
What column is the Product column?  This will get the value for Product from column S.

Regards,

Rob.
Option Explicit
 
Sub Send_Mail()

    Dim rng1 As Range, rng2 As Range, rng3 As Range
    Dim cel As Range
    Dim MyDic As Object
    Dim doit, FirstAddress As String
    Set MyDic = CreateObject("Scripting.Dictionary")
 
    Sheets("DCS").Select
    Set rng1 = Sheets("DCS").Range([k3], Cells(ActiveSheet.Rows.Count, "k").End(xlUp)).SpecialCells(xlConstants)
    For Each cel In rng1
        Set rng3 = Nothing
        If cel.Value <> vbNullString And cel.Offset(0, 7) = "" Then
            If Not MyDic.Exists(cel.Value) Then
                Set rng2 = rng1.Find(cel.Value, rng1.Cells(1), xlValues, xlWhole, xlByRows, xlPrevious)
                If Not rng2 Is Nothing Then
                    Set rng3 = Cells(rng2.row, "q")
                    FirstAddress = rng2.Address
                    Do
                        Set rng2 = rng1.FindNext(rng2)
                        Set rng3 = Union(rng3, Cells(rng2.row, "q"))
                    Loop While FirstAddress <> rng2.Address
                End If
                MyDic.Add cel.Value, cel.row
Mailem rng3
            Else
            End If
        End If
 
    Next
End Sub
 
Sub Mailem(ByVal rng3 As Range)
Dim outApp, outMail
Dim strFooter As String, strHeader As String
Dim c As Range, strBody As String
 
strBody = "Hi " & Left(Cells(rng3.Cells(1).Row, "O").Value, InStr(Cells(rng3.Cells(1).Row, "O").Value, ".") - 1) & ",<br><br> The for each DCS."
strBody = strBody & "<br><br><table border=1><tr><td><B>Type</B></td><td><b>Machine name</b></td><td><b>Product</b></td></tr>"
For Each c In rng3
    If Cells(c.Row, "R") = "" Then
        strBody = strBody & IIf(c.Value = "", "<font color=""#FF0000"">(Please fill in the blank)</font>", "<tr><td align=center>" & c.Value & "</td><td align=center>" & c.Offset(, -1).Value) & "</td><td align=center>" & c.Offset(, 1).Value) & "</td></tr>"
    End If
Next c
strBody = strBody & "</table><br><br><br>Regards, <br>Sharath"
 
Set outApp = CreateObject("Outlook.Application")
outApp.Session.Logon
Set outMail = outApp.CreateItem(0)
With outMail
    .To = Cells(rng3.Cells(1).Row, "O").Value
    .SentOnBehalfOfName = "Information Request<sha@plc.com>"
    .CC = "sha@plc.com;Muruiei@plc.com"
    .Subject = "DCS"
    .HTMLBody = strBody
    .Recipients.ResolveAll
    .Display
End With
Set outMail = Nothing
Set outApp = Nothing
End Sub

Open in new window

Avatar of bsharath
bsharath
Flag of India image

ASKER

Sorry did not mention. Product has to be stand alone
What i mean is thats the info i need to ask users to fill after emailing them. So the header has to be hardcoded and table expanded as per the other 2 fields
Say i have 4 rows of data then the product should also be 4 rows
Just the header and other cells below it blank
Avatar of RobSampson
RobSampson
Flag of Australia image
OK, so change this line:
        strBody = strBody & IIf(c.Value = "", "<font color=""#FF0000"">(Please fill in the blank)</font>", "<tr><td align=center>" & c.Value & "</td><td align=center>" & c.Offset(, -1).Value) & "</td><td align=center>" & c.Offset(, 1).Value) & "</td></tr>"

to this
        strBody = strBody & IIf(c.Value = "", "<font color=""#FF0000"">(Please fill in the blank)</font>", "<tr><td align=center>" & c.Value & "</td><td align=center>" & c.Offset(, -1).Value) & "</td><td align=center>&nbsp;</td></tr>"

Regards,

Rob.
Avatar of bsharath
bsharath
Flag of India image

ASKER

Rob where should i mention the word product
I get as attached
The headers should be changes . The machine name should be first and then the Type
Capture1111.JPG
Avatar of RobSampson
RobSampson
Flag of Australia image
Do you want to prompt the user to enter the product name?

Try this.

Rob,.
Option Explicit
 
Sub Send_Mail()

    Dim rng1 As Range, rng2 As Range, rng3 As Range
    Dim cel As Range
    Dim MyDic As Object
    Dim doit, FirstAddress As String
    Set MyDic = CreateObject("Scripting.Dictionary")
 
    Sheets("DCS").Select
    Set rng1 = Sheets("DCS").Range([k3], Cells(ActiveSheet.Rows.Count, "k").End(xlUp)).SpecialCells(xlConstants)
    For Each cel In rng1
        Set rng3 = Nothing
        If cel.Value <> vbNullString And cel.Offset(0, 7) = "" Then
            If Not MyDic.Exists(cel.Value) Then
                Set rng2 = rng1.Find(cel.Value, rng1.Cells(1), xlValues, xlWhole, xlByRows, xlPrevious)
                If Not rng2 Is Nothing Then
                    Set rng3 = Cells(rng2.row, "q")
                    FirstAddress = rng2.Address
                    Do
                        Set rng2 = rng1.FindNext(rng2)
                        Set rng3 = Union(rng3, Cells(rng2.row, "q"))
                    Loop While FirstAddress <> rng2.Address
                End If
                MyDic.Add cel.Value, cel.row
Mailem rng3
            Else
            End If
        End If
 
    Next
End Sub
 
Sub Mailem(ByVal rng3 As Range)
Dim outApp, outMail
Dim strFooter As String, strHeader As String
Dim c As Range, strBody As String
 
strBody = "Hi " & Left(Cells(rng3.Cells(1).Row, "O").Value, InStr(Cells(rng3.Cells(1).Row, "O").Value, ".") - 1) & ",<br><br> The for each DCS."
strBody = strBody & "<br><br><table border=1><tr><td><B>Machine Name</B></td><td><b>Type</b></td><td><b>Product</b></td></tr>"
strProduct = InputBox("Enter product name:")
For Each c In rng3
    If Cells(c.Row, "R") = "" Then
        strBody = strBody & IIf(c.Value = "", "<font color=""#FF0000"">(Please fill in the blank)</font>", "<tr><td align=center>" & c.Offset(, -1).Value) & "</td><td align=center>" & c.Value & "</td><td align=center>" & c.Offset(, 1).Value) & "</td><td align=center>" & strProduct & "</td></tr>"
    End If
Next c
strBody = strBody & "</table><br><br><br>Regards, <br>Sharath"
 
Set outApp = CreateObject("Outlook.Application")
outApp.Session.Logon
Set outMail = outApp.CreateItem(0)
With outMail
    .To = Cells(rng3.Cells(1).Row, "O").Value
    .SentOnBehalfOfName = "Information Request<sha@plc.com>"
    .CC = "sha@plc.com;Muruiei@plc.com"
    .Subject = "DCS"
    .HTMLBody = strBody
    .Recipients.ResolveAll
    .Display
End With
Set outMail = Nothing
Set outApp = Nothing
End Sub

Open in new window

Avatar of bsharath
bsharath
Flag of India image

ASKER

Rob this line has some error
strBody = strBody & IIf(c.Value = "", "<font color=""#FF0000"">(Please fill in the blank)</font>", "<tr><td align=center>" & c.Offset(, -1).Value) & "</td><td align=center>" & c.Value & "</td><td align=center>" & c.Offset(, 1).Value) & "</td><td align=center>" & strProduct & "</td></tr>"

Its in Red color.
I dont want to prompt but just have the header and table for them to enter within the cells in product
Avatar of RobSampson
RobSampson
Flag of Australia image
Oh, try this.

strBody = strBody & IIf(c.Value = "", "<font color=""#FF0000"">(Please fill in the blank)</font>", "<tr><td align=center>" & c.Offset(, -1).Value) & "</td><td align=center>" & c.Value & "</td><td align=center>" & c.Offset(, 1).Value & "</td><td align=center>" & strProduct & "</td></tr>"
Avatar of bsharath
bsharath
Flag of India image

ASKER

I get variable not defined.

Why is this line

strProduct = InputBox("Enter product name:")

I dont want any popup. Its a mail created for each set of people. say when i run script there are mails created and it will have

Machine name | Type | Product

machine name and type are captured from the excel.

Product has to be blank. After i send an email to receiver will fill that portion
Avatar of RobSampson
RobSampson
Flag of Australia image
OK, what about this.

Rob.
Option Explicit
 
Sub Send_Mail()

    Dim rng1 As Range, rng2 As Range, rng3 As Range
    Dim cel As Range
    Dim MyDic As Object
    Dim doit, FirstAddress As String
    Set MyDic = CreateObject("Scripting.Dictionary")
 
    Sheets("DCS").Select
    Set rng1 = Sheets("DCS").Range([k3], Cells(ActiveSheet.Rows.Count, "k").End(xlUp)).SpecialCells(xlConstants)
    For Each cel In rng1
        Set rng3 = Nothing
        If cel.Value <> vbNullString And cel.Offset(0, 7) = "" Then
            If Not MyDic.Exists(cel.Value) Then
                Set rng2 = rng1.Find(cel.Value, rng1.Cells(1), xlValues, xlWhole, xlByRows, xlPrevious)
                If Not rng2 Is Nothing Then
                    Set rng3 = Cells(rng2.row, "q")
                    FirstAddress = rng2.Address
                    Do
                        Set rng2 = rng1.FindNext(rng2)
                        Set rng3 = Union(rng3, Cells(rng2.row, "q"))
                    Loop While FirstAddress <> rng2.Address
                End If
                MyDic.Add cel.Value, cel.row
Mailem rng3
            Else
            End If
        End If
 
    Next
End Sub
 
Sub Mailem(ByVal rng3 As Range)
Dim outApp, outMail
Dim strFooter As String, strHeader As String
Dim c As Range, strBody As String
 
strBody = "Hi " & Left(Cells(rng3.Cells(1).Row, "O").Value, InStr(Cells(rng3.Cells(1).Row, "O").Value, ".") - 1) & ",<br><br> The for each DCS."
strBody = strBody & "<br><br><table border=1><tr><td><B>Machine Name</B></td><td><b>Type</b></td><td><b>Product</b></td></tr>"
For Each c In rng3
    If Cells(c.Row, "R") = "" Then
		strBody = strBody & IIf(c.Value = "", "<font color=""#FF0000"">(Please fill in the blank)</font>", "<tr><td align=center>" & c.Offset(, -1).Value) & "</td><td align=center>" & c.Value & "</td><td align=center>" & c.Offset(, 1).Value & "</td><td align=center>&nbsp;</td></tr>"
	End If
Next c
strBody = strBody & "</table><br><br><br>Regards, <br>Sharath"
 
Set outApp = CreateObject("Outlook.Application")
outApp.Session.Logon
Set outMail = outApp.CreateItem(0)
With outMail
    .To = Cells(rng3.Cells(1).Row, "O").Value
    .SentOnBehalfOfName = "Information Request<sha@plc.com>"
    .CC = "sha@plc.com;Muruiei@plc.com"
    .Subject = "DCS"
    .HTMLBody = strBody
    .Recipients.ResolveAll
    .Display
End With
Set outMail = Nothing
Set outApp = Nothing
End Sub

Open in new window

Avatar of bsharath
bsharath
Flag of India image

ASKER

Ya now correct but get one small table extra and the Dev64 is the machine name and dcs is the type
So need to change those locations
Can i have all data includng headers in center
Capture1111.JPG
ASKER CERTIFIED SOLUTION
Avatar of RobSampson
RobSampson
Flag of Australia image
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of bsharath
bsharath
Flag of India image

ASKER

Thank you Rob works perfect
Any help with the other one...