Using a macro to select a row of text and email it...

[pontybiker]

Hi,

If possible, I would like the ability to select text from an excel workbook and email it to an email address. The email address would be dependent on what text is in a certain cell.

This is an example of the workbook containing the data (workbook A):[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Sport[/TD]
[TD]£1[/TD]
[TD]£2[/TD]
[TD]AAAA[/TD]
[/TR]
[TR]
[TD]Education[/TD]
[TD]£2[/TD]
[TD]£2[/TD]
[TD]BBBB[/TD]
[/TR]
[TR]
[TD]Managment[/TD]
[TD]£6[/TD]
[TD]£1[/TD]
[TD]CCCC[/TD]
[/TR]
[TR]
[TD]Art[/TD]
[TD]£4[/TD]
[TD]£3[/TD]
[TD]DDDD[/TD]
[/TR]
</tbody>[/TABLE]

This is an example of the email workbook (workbook B);
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Sport[/TD]
[TD]j@j.com[/TD]
[/TR]
[TR]
[TD]Education[/TD]
[TD]b@j.com[/TD]
[/TR]
[TR]
[TD]Management[/TD]
[TD]g@j.com[/TD]
[/TR]
[TR]
[TD]Art[/TD]
[TD]k@j.com[/TD]
[/TR]
</tbody>[/TABLE]

So the code would need to email the row of text in workbook A to the email address in workbook B by matching the text in column A in workbook A to the correct email address in column B in workbook B.

I hope this makes sense. I realise this may be asking a lot. As always, I honestly do appreciate anyone's help with these questions.

Kind regards,

J.

 

[Fishboy]

That's great, it works perfectly.

I have two more things I'd like to add to it but I feel I've asked too much of you already. Let me know if you have time or if you have had enough.

I know I have said it several times but really, this is going to help me so much with my job.

J.

Happy to hear it is working now

I'm always happy to try and help, but I can't always guarantee I will have the solution!

Feel free to let me know what else you would like to try and add and I will see what I can do, just bear in mind that I am also probably helping a handful of other people on here at the same time, as well as doing my "real" job too. That isn't meant to deter you but just to let you know that sometimes it might take me a little while to get back to you.

 

[pontybiker]

I totally understand.

The two additions I would like to add are, the ability to add the row of column headings from workbook A which will always be A6:H6 in the email so that the data makes sense.

The second addition is: some of the departments in workbook A are not in workbook B as we know, however, is it possible to say if a department starts with CSAD then send it to xxx?

I totally understand you are extremely busy. Thanks for everything you have done so far.

J.

 

[pontybiker]

Hi Fishboy,

Yes, it me again. I just wondered if you would have time at some-point to look at my amendments. No worries if not. I know you are super busy. After all, you have helped me loads already.

J.

 

[Fishboy]

Hi Fishboy,

Yes, it me again. I just wondered if you would have time at some-point to look at my amendments. No worries if not. I know you are super busy. After all, you have helped me loads already.

J.

Hi Jamie,

To be completely honest I had totally forgotten about this entirely! I will dust off the old code I gave you and have another look at your latest query. Leave it with me and I will see if it is something I can help with.

 

[Fishboy]

Try replacing the main code with this. Amendments have been highlighted in bold red, the bold blue part will need to be updated with the default email address you want to use for CSAD departments:

Sub MailWithLookupLoop()
' Defines variables
Dim wb1 As Workbook, wb2 As Workbook, FindString As String, EmailAdd As String, Cell As Range, cRange As Range, lRange As Range
' Disable screen updating to reduce flicker
Application.ScreenUpdating = False


'''SETUP WORKBOOK 1'''
' If Telephone-Charges is not already open (amend file path as required) then...
If Not IsFileOpen("C:\Users\sm18441\Documents\Call Logger\Telephone-Charges.xlsx") Then
    ' Open and Sets wb1 as Telephone-Charges.xlsx (amend file path as required)
    Set wb1 = Workbooks.Open("C:\Users\sm18441\Documents\Call Logger\Telephone-Charges.xlsx")
    ' Re-activate wb1
    wb1.Activate
' Else if EmailList is already open then...
Else
    ' Sets wb1 as Telephone-Charges.xlsx
    Set wb1 = Workbooks("Telephone-Charges.xlsx")
End If
' Defines LastRow1 as the last row of data on wb1 sheet1 based on column A
LastRow1 = wb1.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
' Sets the check range as A1 to the last row of A on wb1 sheet1
Set cRange = wb1.Sheets(1).Range("A1:A" & LastRow1)




'''SETUP WORKBOOK 2'''
' If EmailList is not already open (amend file path as required) then...
If Not IsFileOpen("C:\Users\sm18441\Documents\Call Logger\emaillist.xlsx") Then
    ' Open and Sets wb2 as emaillist.xlsx (amend file path as required)
    Set wb2 = Workbooks.Open("C:\Users\sm18441\Documents\Call Logger\emaillist.xlsx")
    ' Re-activate wb1
    wb1.Activate
' Else if EmailList is already open then...
Else
    ' Sets wb2 as emaillist.xlsx
    Set wb2 = Workbooks("emaillist.xlsx")
End If
' Defines LastRow2 as the last row of data of wb2 sheet1 based on column A
LastRow2 = wb2.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
' Sets lookup range as A1 to the last row of B on wb2 sheet1
Set lRange = wb2.Sheets(1).Range("A1:B" & LastRow2)


'''START LOOP'''
' For each cell in the check range
For Each Cell In cRange
    ' Sets variable FindString as the contents of the current cell on wb1 sheet1
    FindString = Cell.Value
    ' On error continue
    On Error Resume Next
    ' Sets variable EmailAdd to nothing
    EmailAdd = ""
    ' Sets variable EmailAdd as the corresponding email address based on the FindString on wb2 sheet1
    EmailAdd = Application.WorksheetFunction.VLookup(FindString, lRange, 2, False)
       
'''
'''OPTIONAL MESSAGE IF DEPARTMENT IS NOT FOUND - DELETE THE BELOW SECTION FOR SEAMLESS PROCESSING'''
' If an error is encountered then...
    If Err.Number <> 0 Then
        If Left(FindString, 4) = "CSAD" Then
            EmailAdd = "PUT THE DESIRED DEFAULT EMAIL ADDRESS HERE"
        Else
            ' Display message that the department was not found and move on
            MsgBox FindString & " department not found.  Moving on."
        End If
    End If
'''END OF OPTIONAL MESSAGE PART - DELETE THE ABOVE SECTION FOR SEAMLESS PROCESSING'''
'''
    
    ' If EmailAdd is not blank then
    If EmailAdd <> "" Then
        ' Select the range of cells on the ws1 as this is what will be emailed
        wb1.Sheets(1).Range("A6:H6", "A" & Cell.Row, "D" & Cell.Row).Select
        ' Show the envelope on the ActiveWorkbook
        ActiveWorkbook.EnvelopeVisible = True
        With ActiveSheet.MailEnvelope
            ' Sets the optional introduction fields thats adds
           .Introduction = "This is what will be in the opening of your email"
           ' Send to the email address in EmailAdd
           .Item.To = EmailAdd
           ' Define your desired subject line
           .Item.Subject = "Your chosen email subject"
           ' Send the email
           .Item.Send
        End With
    End If
' Check next cell in check range
Next Cell
'''END LOOP'''


' Re-enable screen updating
Application.ScreenUpdating = True
' Display message box to confirm the process has completed
MsgBox "All mails sent."


End Sub

[EDIT!] Wait! This is now mailing everything instead of just the headers and desired departmental line. Leave it with me a little longer!

 

[Fishboy]

I've had to start my own thread HERE to ask the gurus how to select the header row and the desired row ready to be emailed instead of picking up everything.

Hopefully we'll get some additional progress soon!

 

[pontybiker]

I've had to start my own thread HERE to ask the gurus how to select the header row and the desired row ready to be emailed instead of picking up everything.

Hopefully we'll get some additional progress soon!

Hi Fishboy, sorry for not getting back yesterday, I had to pop to the hospital again. You have done an extraordinary amount of work to help me yet again, thank you so much, I honestly don't know what to say.

I will wait to hear from you, thank you once again.

J.

 

[Fishboy]

Hi Fishboy, sorry for not getting back yesterday, I had to pop to the hospital again. You have done an extraordinary amount of work to help me yet again, thank you so much, I honestly don't know what to say.

I will wait to hear from you, thank you once again.

J.

I have had my first reply to my query, however unfortunately the suggested solution has the same issue as my current code. The header row, the "current" row and everything in between is picked up in the email. I shall continue to investigate.

 

[pontybiker]

I have had my first reply to my query, however unfortunately the suggested solution has the same issue as my current code. The header row, the "current" row and everything in between is picked up in the email. I shall continue to investigate.

Thanks Fishboy. I feel helpless, if I can do anything let me know.