change to macro coding to send multiple lines

HI

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 robmarr789@gmail.com (1 email to be sent only)

      



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

Thanks Rob
Copy-of-DIRECT-Central-Terms-encrypted.x
mikes6058Asked:
Who is Participating?
 
Saqib Husain, SyedEngineerCommented:
Try
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 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
    End If
Next

End Sub

Open in new window

0
 
Saqib Husain, SyedEngineerCommented:
I could not find a macro
0
 
mikes6058Author Commented:
see attached
0
Cloud Class® Course: Ruby Fundamentals

This course will introduce you to Ruby, as well as teach you about classes, methods, variables, data structures, loops, enumerable methods, and finishing touches.

 
mikes6058Author Commented:
0
 
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)

Thanks
Master-Query-Log.xlsm
0
 
Saqib Husain, SyedEngineerCommented:
I think for condition 3 a different approach should be adopted. You should open a new question.
0
 
mikes6058Author Commented:
Excellent solution.

I have opened a new question for the next steps (see below).

http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28656182.html
0
 
mikes6058Author Commented:
Great work
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.