We help IT Professionals succeed at work.

change to macro coding to send multiple lines

mikes6058 asked

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
Watch Question

I could not find a macro


see attached
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)
          End With
          Set OutMail = Nothing
          Set OutApp = Nothing
          Kill Environ("temp") & "\" & attachname
        End If
    End If

End Sub

Open in new window


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)

I think for condition 3 a different approach should be adopted. You should open a new question.


Excellent solution.

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



Great work