change to macro coding to send multiple lines


Attached is a spreadsheet with a number of rows containing basic trading terms for a number of companies (made up). Column T contains an email address.

The button on the sheet has a macro assigned to it which is designed to split the top row of headings and each individual separate row and then send those two rows to the relevant email address in column T in a separate excel worksheet.

However I would like to alter the macro so that if the same email address appears in multiple rows then each of these rows is collated together along with the top row of column headings into one spreadsheet and then sent as one email attachment to that email address.

Based on the example (example sheet) attached I would expect a workbook containing the following to be sent to (1 email to be sent only)


Would anyone be able to alter the coding in the macro to this?

Thanks Rob
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Saqib Husain, SyedEngineerCommented:
I could not find a macro
mikes6058Author Commented:
see attached
mikes6058Author Commented:
C++ 11 Fundamentals

This course will introduce you to C++ 11 and teach you about syntax fundamentals.

Saqib Husain, SyedEngineerCommented:
Sub test()

Dim original_wb As Workbook
Dim new_wb As Workbook

Set original_wb = ActiveWorkbook 'Workbooks.Open("C:\THS Direct Admin\DIRECT supplier Terms\Copy of DIRECT Central Terms encrypted.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 T
    If emailaddress <> "" Then
        findprevem = Application.Match(emailaddress, original_wb.Sheets(1).Range(original_wb.Sheets(1).Cells(2, 20), original_wb.Sheets(1).Cells(i - 1, 20)), 0)
        If IsError(findprevem) Then
          Set new_wb = Workbooks.Add
          original_wb.Sheets(1).Range("A1").EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A1")
          For j = i To row_count
            If original_wb.Sheets(1).Cells(i, 20).Value = original_wb.Sheets(1).Cells(j, 20).Value Then
                original_wb.Sheets(1).Range("A" & j).EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1)
            End If
          Next j
          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" & 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)
          End With
          Set OutMail = Nothing
          Set OutApp = Nothing
          Kill Environ("temp") & "\" & attachname
        End If
    End If

End Sub

Open in new window


Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
mikes6058Author Commented:
That's brilliant, exactly what I wanted it to do.

Now I need exactly the same code to be applied to the attached sheet only with the following differences....

1. Only send columns in the range A:W - do not include any columns after this.
2. Change it so it sends to the email address in column W
3. Do not collate and send rows where column X contains (RESOLVED) or column Y contains (INTERNAL QUERY)

Saqib Husain, SyedEngineerCommented:
I think for condition 3 a different approach should be adopted. You should open a new question.
mikes6058Author Commented:
Excellent solution.

I have opened a new question for the next steps (see below).
mikes6058Author Commented:
Great work
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.