Link to home
Start Free TrialLog in
Avatar of mikes6058
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:\Supplier Relations\Current Supplier Info\Database\Rob\member email addresses as of (26.05.2015).xlsm") '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
   
    attachname = "THS_Direct_Trading_Terms_Contact_Details.xlsx"
    emailaddress = original_wb.Sheets(1).Cells(i, 20).Value 'email address from column B
    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

End Sub
Avatar of Ingeborg Hawighorst (Microsoft MVP / EE MVE)
Ingeborg Hawighorst (Microsoft MVP / EE MVE)
Flag of New Zealand image

Hello,

have you tried

Dim original_wb As Workbook
Dim new_wb As Workbook


Set original_wb = ActiveWorkbook

Open in new window


cheers teylyn
Avatar of mikes6058
mikes6058

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
For the given file change

    emailaddress = original_wb.Sheets(1).Cells(i, 20).Value 'email address from column B

to

    emailaddress = original_wb.Sheets(1).Cells(i, 2).Value 'email address from column B
the point is that the macro is not running when I change

Set original_wb = Workbooks.Open("P:\Supplier Relations\Current Supplier Info\Database\Rob\member email addresses as of (26.05.2015).xlsm") 'adjust file location

to

Set original_wb = ActiveWorkbook
ASKER CERTIFIED SOLUTION
Avatar of Saqib Husain
Saqib Husain
Flag of Pakistan 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