Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations IamaSherpa on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

covert excel rows to outlook body using VBA

Status
Not open for further replies.

Raynepau

Technical User
Dec 30, 2010
33
GB
Hi

Can anyone help. I am a relative newcomer to VB and am trying to find / write some code to do the following

I have an excel workbook with a worksheet that has two columns entitled, “firstname” and “Surname"

I would like to search the column A (firstname) based on criteria and then drop the firstname with the surname into the body of an email

So if I have a criteria of “Dave” with the following table

Firstname Surname
Dave Smith
Bob Johnson
Dave Jones
Terry Palin
Ken Scott

The email would then look like this

Person 1
First Name: Dave
Surname: Smith

Person 2
First Name: Dave
Surname: Jones

There could be more than two Daves so the email would grow or shrink depending on the number of rows with a Dave

I have attempted to use the code below but it does not work

Any help would be appreciated

Please bear in mind that I do not fully understand this code but have copied it from various sources and cannot get it to work

Sub Button2_Click()


Dim C As Range
Dim P As Long
Dim firstAddress As String
Dim OutApp As Object
Dim OutMail As Object
Dim exptrknumber As String
Dim claimantemail As String
Dim ccemail As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
createemail:
On Error Resume Next
With OutMail
.to = ""
.CC = ""
.BCC = ""
.Subject = "EMEA Morning Report - " & Date

With Worksheets("Incidents").Range("A1:A5000")
Set C = .Find("DAVE", LookIn:=xlValues)
If Not C Is Nothing Then
firstAddress = C.Row
Do
FirstName = ["A"& C.Row]
Surname = ["B"& C.Row]

.BodyFormat = olFormatHTML
.HTMLBody = "Person ” & C.Row
.HTMLBody = .HTMLBody & "<br/><br/><b> First Name: </b>" " & FirstName
.HTMLBody = .HTMLBody & "<br/><br/><b>Surname: </b>" & Surname

Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Row <> firstAddress
End If


.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

End With
End Sub
 
Hi,

Where do you have your code?

What do you mean by "cannot get it to work"? There are a whole range of possibilities.

Please answer both questions fully.

Skip,

[glasses]Just traded in my old subtlety...
for a NUANCE![tongue]
 
If you have this in your Excel:

[pre]
A B
1 Firstname Surname

2 Dave Smith
3 Bob Johnson
4 Dave Jones
5 Terry Palin
6 Ken Scott
[/pre]

In Excel you can pick 'Dave' this way:

Code:
Dim i As Integer
Dim X As Integer

i = 2

Do While Range("A" & i).Value <> ""
    If Range("A" & i).Value = "Dave" Then
        X = X + 1
        MsgBox "Person " & X & ": " & Range("A" & i).Value & " " & Range("B" & i).Value
    End If
    i = i + 1
Loop

Have fun.

---- Andy
 
Your code did not compile as posted.

this does
Code:
Sub Button2_Click()

    Dim C As Range
    Dim P As Long
    Dim firstName As String
    Dim firstAddress As String
    Dim Surname As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim exptrknumber As String
    Dim claimantemail As String
    Dim ccemail As String
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
createemail:
    On Error Resume Next
    With OutMail
        .to = ""
        .CC = ""
        .BCC = ""
        .Subject = "EMEA Morning Report - " & Date
        
        With Worksheets("Incidents").Range("A1:A5000")
            Set C = .Find("DAVE", LookIn:=xlValues)
            If Not C Is Nothing Then
                firstAddress = C.Row
                Do
                    firstName = Cells(C.Row, "A")
                    Surname = Cells(C.Row, "B")
                    
                    .BodyFormat = olFormatHTML
                    .HTMLBody = "Person ” & C.Row"
                    .HTMLBody = .HTMLBody & "<br/><br/><b> First Name: </b>" & firstName
                    .HTMLBody = .HTMLBody & "<br/><br/><b>Surname: </b>" & Surname
                    
                    Set C = .FindNext(C)
                Loop While Not C Is Nothing And C.Row <> firstAddress
            End If
            
            .Display
        End With
        On Error GoTo 0
        Set OutMail = Nothing
        Set OutApp = Nothing
    
    End With
End Sub

Skip,

[glasses]Just traded in my old subtlety...
for a NUANCE![tongue]
 
Skip / Andy

Thanks for your help. I have changed a couple of things that fit my spreadsheet. For example, the column to be searched is B and I am really searching for the word SEND and not DAVE

However, I still cannot get the email part to work

Outlook does not even open up

As you can see I have added a message box so I can checked that it is finding and showing the correct row number and this part works

The code is in a module

Hope this helps

Thanks

Sub Button2_Click()


Dim C As Range
Dim P As Long
Dim firstName As String
Dim firstAddress As String
Dim Surname As String
Dim OutApp As Object
Dim OutMail As Object
Dim exptrknumber As String
Dim claimantemail As String
Dim ccemail As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
createemail:
On Error Resume Next
With OutMail
.to = ""
.CC = ""
.BCC = ""
.Subject = "EMEA Morning Report - " & Date

With Worksheets("Incidents").Range("B1:B5000")
Set C = .Find("SEND", LookIn:=xlValues)
If Not C Is Nothing Then
firstAddress = C.Row
Do
firstName = Cells(C.Row, "B")
Surname = Cells(C.Row, "D")

.BodyFormat = olFormatHTML
.HTMLBody = "Person ” & C.Row"
.HTMLBody = .HTMLBody & "<br/><br/><b> First Name: </b>" & firstName
.HTMLBody = .HTMLBody & "<br/><br/><b>Surname: </b>" & Surname
MsgBox C.Row
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Row <> firstAddress
End If

.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

End With
End Sub
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top