mikes6058
asked on
run macro on activeworkbook
Can any one adjust the code pasted below so that when I run the macro it will automatically run in the code against the contents of the active workbook rather than opening a chosen file for it to run on?
I believe you will need to change the bit of code in BOLD
Sub test()
Dim original_wb As Workbook
Dim new_wb As Workbook
Set original_wb = Workbooks.Open("P:\Supplie r Relations\Current Supplier Info\Database\Rob\member email addresses as of (26.05.2015).xlsm") 'adjust file location
row_count = original_wb.Sheets(1).Used Range.Rows .Count
col_count = original_wb.Sheets(1).Used Range.Colu mns.Count
For i = 2 To row_count Step 1
attachname = "THS_Direct_Trading_Terms_ Contact_De tails.xlsx "
emailaddress = original_wb.Sheets(1).Cell s(i, 20).Value 'email address from column B
If emailaddress <> "" Then
Set new_wb = Workbooks.Add
original_wb.Sheets(1).Rang e("A1").En tireRow.Co py Destination:=new_wb.Sheets (1).Range( "A1")
original_wb.Sheets(1).Rang e("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.Appl ication")
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
End Sub
I believe you will need to change the bit of code in BOLD
Sub test()
Dim original_wb As Workbook
Dim new_wb As Workbook
Set original_wb = Workbooks.Open("P:\Supplie
row_count = original_wb.Sheets(1).Used
col_count = original_wb.Sheets(1).Used
For i = 2 To row_count Step 1
attachname = "THS_Direct_Trading_Terms_
emailaddress = original_wb.Sheets(1).Cell
If emailaddress <> "" Then
Set new_wb = Workbooks.Add
original_wb.Sheets(1).Rang
original_wb.Sheets(1).Rang
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.Appl
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
End Sub
ASKER
yes I have but when I run the macro nothing happens.
please find attached for testing.
When you run the macro it should send "each" row and the column headings in a separated worksheet to the corresponding email address populated in column B.
member-email-addresses-2.xlsm
please find attached for testing.
When you run the macro it should send "each" row and the column headings in a separated worksheet to the corresponding email address populated in column B.
member-email-addresses-2.xlsm
For the given file change
emailaddress = original_wb.Sheets(1).Cell s(i, 20).Value 'email address from column B
to
emailaddress = original_wb.Sheets(1).Cell s(i, 2).Value 'email address from column B
emailaddress = original_wb.Sheets(1).Cell
to
emailaddress = original_wb.Sheets(1).Cell
ASKER
the point is that the macro is not running when I change
Set original_wb = Workbooks.Open("P:\Supplie r Relations\Current Supplier Info\Database\Rob\member email addresses as of (26.05.2015).xlsm") 'adjust file location
to
Set original_wb = ActiveWorkbook
Set original_wb = Workbooks.Open("P:\Supplie
to
Set original_wb = ActiveWorkbook
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
have you tried
Open in new window
cheers teylyn