Solved

send separate rows to all emails excel

Posted on 2014-12-10
16
264 Views
Last Modified: 2014-12-11
Attached is a spread sheet with Supplier trading terms

Each row has a set of trading terms relating to a different supplier. The supplier name is located in column A which I have encrypted for confidentiality purposes.

I would like to be able to send the column headings along with the single row for each supplier as an attachment (excel file) to the suppliers email address in column T(again encrypted). The rest of the rows need to be omitted from the sheet as the suppliers should only be able to see the row relating to their own terms.

Is there a piece of coding that will allow me to do this in once click of a button?
I'd also need the email to have a standard subject and body text which will be the same for all of the emails sent.
I will be using Microsoft Outlook 2010.

Rob
DIRECT-Central-Terms-encrypted.xlsx
0
Comment
Question by:robmarr700
  • 8
  • 8
16 Comments
 
LVL 35

Expert Comment

by:Kimputer
ID: 40491031
Yes it's quite possible.
Using VBA code and a button, it would go through all rows and do exactly as you wish by:
Looping all rows, doing:
create a new excel file, write header, write line
save excel file
create new email with TO: (data from column T), subject (something default), attach excel file, even have some generic message body
send mail, delete file
loop again till end of rows

Only thing might be that Outlook will start throwing warning messages (which you need to click away before it can continue) due to protection from malware.

I could code it, but it will take you some time. If other experts chime in, it could be done in a jiffy.
0
 

Author Comment

by:robmarr700
ID: 40491073
Sounds so simple when you put it like that. Perhaps you could make a start and experts could chip in along the way?

Rob
0
 
LVL 35

Expert Comment

by:Kimputer
ID: 40491142
Sub test()


'insert code for opening excel file

'adjust activesheet/sheet 2 to ??? need answer

row_count = ActiveSheet.UsedRange.Rows.Count

For i = 3 To row_count Step 1

'insert code, create new excel file name temp folder\i.xlsx
'insert code, copy row 1 (header) to new file
'insert code, copy row i to new file
'insert code, save file, close file

emailaddress = ActiveSheet.Cells(i, 20).Value 'email address from column T

'insert code, outlook new email, attach etc
'insert code delete file

Next

End Sub

Open in new window


Maybe I have some more time later on today
0
 

Author Comment

by:robmarr700
ID: 40491168
That's great, hopefully some other experts will chip in in the meantime

Rob
0
 
LVL 35

Expert Comment

by:Kimputer
ID: 40491334
In the meantime, we are looking at sheet2 of your file. Since this macro is probably meant to be run on a blank excel file with just the code, I need to know if the file name is always the same (or you want to choose the file yourself), and if it's always sheet2 (as name), or always the only sheet, or always the first sheet?
0
 

Author Comment

by:robmarr700
ID: 40491362
The file will always be the same with sheet two used.

Rob
0
 
LVL 35

Expert Comment

by:Kimputer
ID: 40491432
Code so far. Header is problematic, since you merged cells, therefore there's no real one row header anymore. Do you think you can fix that, and just let it start at row 2 (right now row 3)?
If not, it just means I need 25 rows of extra code (to set the header as text, code already there, just add extra headers).

Adjust subject, adjust body and you're almost all done.
Then either make a button, assign macro, or just have it run as soon as you open this excel file (put it in the Private Sub Workbook_Open()
End Sub)

Sub test()


Dim original_wb As Workbook
Dim new_wb As Workbook

'adjust code for opening excel file
Set original_wb = Workbooks.Open("C:\Users\Kimputer\Documents\DIRECT-Central-Terms-encrypted.xlsx")

row_count = original_wb.Sheets(1).UsedRange.Rows.Count
col_count = original_wb.Sheets(1).UsedRange.Columns.Count

For i = 3 To row_count Step 1
    
    emailaddress = original_wb.Sheets(1).Cells(i, 20).Value 'email address from column T
    Set new_wb = Workbooks.Add
    
    'adjust header code
    original_wb.Sheets(1).Range("A1").EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A1")

'alternative if you don't want to touch the header
    'original_wb.Sheets(1).Cells(1, 1).Value = "header1"
    'original_wb.Sheets(1).Cells(1, 2).Value = "header2"
    'all the way till
    'original_wb.Sheets(1).Cells(1, 25).Value = "header25"
    

    original_wb.Sheets(1).Range("A" & i).EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A2")
    
    Application.DisplayAlerts = False
    new_wb.SaveAs Environ("temp") & "\" & i & ".xlsx"
    new_wb.Close SaveChanges:=False
    Set new_wb = Nothing
    Application.DisplayAlerts = True
    
    
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
            .to = emailaddress
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line" 'adjust subjectline!
            .Body = "Hi there" 'adjust body text!
            .Attachments.Add (Environ("temp") & "\" & i & ".xlsx")
            .Send
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Kill Environ("temp") & "\" & i & ".xlsx"

Next

End Sub

Open in new window

0
 

Author Comment

by:robmarr700
ID: 40491836
I've made the adjustments to the merged cells, hopefully this should resolve things. (see attached).
DIRECT-Central-Terms-encrypted.xlsx
0
Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

 
LVL 35

Accepted Solution

by:
Kimputer earned 500 total points
ID: 40491921
This is the final code then (except adjust subject line and body message, also adjust where the file will be located)
Also as said before, either make a button for this macro, or put it in the workbook_open sub
Sub test()


Dim original_wb As Workbook
Dim new_wb As Workbook


Set original_wb = Workbooks.Open("C:\Users\Kimputer\Documents\DIRECT-Central-Terms-encrypted.xlsx") 'adjust file location

row_count = original_wb.Sheets(1).UsedRange.Rows.Count
col_count = original_wb.Sheets(1).UsedRange.Columns.Count

For i = 2 To row_count Step 1
    
    emailaddress = original_wb.Sheets(1).Cells(i, 20).Value 'email address from column T
    Set new_wb = Workbooks.Add
    
    original_wb.Sheets(1).Range("A1").EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A1")
    original_wb.Sheets(1).Range("A" & i).EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A2")
    
    Application.DisplayAlerts = False
    new_wb.SaveAs Environ("temp") & "\" & i & ".xlsx"
    new_wb.Close SaveChanges:=False
    Set new_wb = Nothing
    Application.DisplayAlerts = True
  
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
            .To = emailaddress
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line" 'adjust subjectline!
            .Body = "Hi there" 'adjust body text!
            .Attachments.Add (Environ("temp") & "\" & i & ".xlsx")
            .Send
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Kill Environ("temp") & "\" & i & ".xlsx"

Next

End Sub

Open in new window

0
 

Author Comment

by:robmarr700
ID: 40493476
This may sound stupid but how do I change the coding so that the body of the email displays exactly as below. e.g. spacing, font, font colour etc.

Dear Supplier,

Attached are the terms/details we hold on file for your current trading terms and contact details with THS direct. Please can you confirm these details are correct by placing a 1 in cell Z3.
If there are any differences please overwrite the current terms in red font.
Once confirmed please return the complete spreadsheet to rob.marr@thstools.co.uk

These terms will be incorporated into our THS Supplier Buying Agreement (SBA) which will subsequently be sent to yourselves to sign and return.

Rob
0
 
LVL 35

Expert Comment

by:Kimputer
ID: 40493490
Replace in your code:

.Body = "Dear Supplier," & vbcrlf &  vbcrlf & "Attached are the terms/details we hold on file for your current trading terms and contact details with THS direct. Please can you confirm these details are correct by placing a 1 in cell Z3." & vbcrlf & "If there are any differences please overwrite the current terms in red font." & vbcrlf &  "Once confirmed please return the complete spreadsheet to rob.marr@thstools.co.uk" & vbcrlf & vbcrlf & "These terms will be incorporated into our THS Supplier Buying Agreement (SBA) which will subsequently be sent to yourselves to sign and return." & vbcrlf & vbcrlf & "Rob"

Open in new window


This is just plain text though, no font or color whatsoever, as the email will be sent in plain text too.
0
 

Author Comment

by:robmarr700
ID: 40493500
That's great. Sorry just one more thing.

Is it possible to add a piece of code so that if a cell is vacant in column T (no email address present) it just skips this row out and moves onto the next?

Rob
0
 
LVL 35

Expert Comment

by:Kimputer
ID: 40493505
Replace for loop code:

For i = 2 To row_count Step 1
    
    emailaddress = original_wb.Sheets(1).Cells(i, 20).Value 'email address from column T
    if emailaddress <> "" then
		Set new_wb = Workbooks.Add
		
		original_wb.Sheets(1).Range("A1").EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A1")
		original_wb.Sheets(1).Range("A" & i).EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A2")
		
		Application.DisplayAlerts = False
		new_wb.SaveAs Environ("temp") & "\" & i & ".xlsx"
		new_wb.Close SaveChanges:=False
		Set new_wb = Nothing
		Application.DisplayAlerts = True
	  
		Set OutApp = CreateObject("Outlook.Application")
		Set OutMail = OutApp.CreateItem(0)
		With OutMail
				.To = emailaddress
				.CC = ""
				.BCC = ""
				.Subject = "This is the Subject line" 'adjust subjectline!
				.Body = "Dear Supplier," & vbcrlf &  vbcrlf & "Attached are the terms/details we hold on file for your current trading terms and contact details with THS direct. Please can you confirm these details are correct by placing a 1 in cell Z3." & vbcrlf & "If there are any differences please overwrite the current terms in red font." & vbcrlf &  "Once confirmed please return the complete spreadsheet to rob.marr@thstools.co.uk" & vbcrlf & vbcrlf & "These terms will be incorporated into our THS Supplier Buying Agreement (SBA) which will subsequently be sent to yourselves to sign and return." & vbcrlf & vbcrlf & "Rob"
				.Attachments.Add (Environ("temp") & "\" & i & ".xlsx")
				.Send
		End With
		
		Set OutMail = Nothing
		Set OutApp = Nothing
		
		Kill Environ("temp") & "\" & i & ".xlsx"
	end if
Next

Open in new window

0
 

Author Comment

by:robmarr700
ID: 40493508
Excellent also is it possible to name the attached excel file THS Direct Trading Terms/Contact Details

Rob
0
 
LVL 35

Assisted Solution

by:Kimputer
Kimputer earned 500 total points
ID: 40493521
Replace same for loop as before:

For i = 2 To row_count Step 1
    
	attachname = "THS_Direct_Trading_Terms_Contact_Details.xlsx"
    emailaddress = original_wb.Sheets(1).Cells(i, 20).Value 'email address from column T
    if emailaddress <> "" then
		Set new_wb = Workbooks.Add
		
		original_wb.Sheets(1).Range("A1").EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A1")
		original_wb.Sheets(1).Range("A" & i).EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A2")
		
		Application.DisplayAlerts = False
		new_wb.SaveAs Environ("temp") & "\" & attachname
		new_wb.Close SaveChanges:=False
		Set new_wb = Nothing
		Application.DisplayAlerts = True
	  
		Set OutApp = CreateObject("Outlook.Application")
		Set OutMail = OutApp.CreateItem(0)
		With OutMail
				.To = emailaddress
				.CC = ""
				.BCC = ""
				.Subject = "This is the Subject line" 'adjust subjectline!
				.Body = "Dear Supplier," & vbcrlf &  vbcrlf & "Attached are the terms/details we hold on file for your current trading terms and contact details with THS direct. Please can you confirm these details are correct by placing a 1 in cell Z3." & vbcrlf & "If there are any differences please overwrite the current terms in red font." & vbcrlf &  "Once confirmed please return the complete spreadsheet to rob.marr@thstools.co.uk" & vbcrlf & vbcrlf & "These terms will be incorporated into our THS Supplier Buying Agreement (SBA) which will subsequently be sent to yourselves to sign and return." & vbcrlf & vbcrlf & "Rob"
				.Attachments.Add (Environ("temp") & "\" & attachname)
				.Send
		End With
		
		Set OutMail = Nothing
		Set OutApp = Nothing
		
		Kill Environ("temp") & "\" & attachname
	end if
Next

Open in new window


You may notice the file name is different than the one you wanted, but in general, filenames without spaces are less error prone.
0
 

Author Comment

by:robmarr700
ID: 40493606
Excellent great job
0

Featured Post

Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

What is a Form List Box? (skip if you know this) The forms List Box is the alternative to the ActiveX list box. If you are using excel 2007, you first make sure you have a developer tab (click the Orb)->"Excel Options"->Popular->"Show Developer tab…
Workbook link problems after copying tabs to a new workbook? David Miller (dlmille) Intro Have you either copied sheets to a new workbook, and after having saved and opened that workbook, you find that there are links back to the original sou…
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.

743 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

14 Experts available now in Live!

Get 1:1 Help Now