VBA Script Help: Need to filter spreadsheet by Unique Vendor and Email to Corresponding Vendor then Loop

S

strangejosh

New Member
Joined
Jul 30, 2022
Messages
15
Office Version
  1. 2019
Platform
  1. Windows
Hello,

This takes me forever to do manually. I was hoping someone here could help me automate with a VBA script!!

Please see below example. I am not great with VBA so I could use some help please! I need to filter by unique vendor number in Column B. Then copy and paste all rows / columns from that unique vendor into the body of an emial and send that to the corresponding vendor email. Then I need to loop through and do the same for all of the other unique vendor numbers in the list.

So first part is filter through each unique vendor and copy and paste that into the body of an email to be sent to the corresponding email address in column U. I don't need the emails to send just to be created.

Header for email is Vendor Name in column Q + "Past Due Orders".

Body should contain the data from that unique vendor copy and pasted as well as the text "Hello xxxxx (whatever the name is in the corresponding column T",

"Please see below past due order(s) and provide and updated ship week when you can. Thank you"

ENTERED_BYVENDOR_NOSKUUPCEAQUANTITYFOB_COSTDESTINATION_WAREHOUSEREQUESTED_SHIP_WEEKCURRENT_SHIP_COMMIT_WEEKPONUMBERPO_OPEN_QTYSHIPPED_QTYRECEIVED_QTYBalanceCOMMENTSVENDOR_NAMEExt Balance CostCustomVENDOR_CONTACT_INFO.CONTACT_NAMEVENDOR_CONTACT_INFO.CONTACT_EMAIL_ADDRESSSKU_INFO.BUYER_CODERB EmailUpdated Ship Week
John
123​
1​
240​
EA
4800​
$ 5.00OR21.2237.22
6474​
4440​
0​
360​
4440​
Company$ 22,200.00BKeithkeith@abc.comDEde@abc.com
Sarah
1234​
2​
207​
EA
2400​
$ 3.00KY15.2230.22
8084​
950​
0​
1450​
950​
Active$ 2,850.00BPattyPatty@123.comDHdh@fakemail.com
George
12345​
3​
251​
EA
912​
$ 8.00TX07.2234.22
9997​
192​
0​
720​
192​
LTD$ 1,536.00BTonytony@fakemail.comLHlh@go.com
Samantha
123456​
4​
270​
EA
8088​
$ 10.00OR16.2212.22
5131​
320​
0​
7768​
320​
Wheels$ 3,200.00BChristinechristine@go.comSWsw@help.com
Betsy
1234567​
5​
253​
EA
2688​
$ 2.00DIL30.2231.22
8065​
768​
0​
1920​
768​
Wheels$ 1,536.00BRoryrory@email.comLHlh@go.com
Betsy
1234567​
6​
236​
EA
2880​
$ 3.00OR27.2228.22
6142​
960​
0​
1920​
960​
Wheels$ 2,880.00BRoryrory@email.comR6r6@abc.com
Betsy
1234567​
7​
274​
EA
4000​
$ 3.00KY29.2235.22
8757​
2800​
0​
1200​
2800​
Wheels$ 8,400.00BRoryrory@email.comLHlh@go.com
Betsy
1234567​
8​
209​
EA
1440​
$ 8.00KY30.2236.22
8864​
480​
0​
960​
480​
Wheels$ 3,840.00BRoryrory@email.comR6r6@abc.com
Betsy
1234567​
9​
256​
EA
3840​
$ 9.00OR28.2228.22
8841​
768​
0​
3072​
768​
Wheels$ 6,912.00BRoryrory@email.comLHlh@go.com
Betsy
1234567​
10​
216​
EA
1920​
$ 2.00OR28.2228.22
6490​
960​
0​
960​
960​
Wheels$ 1,920.00BRoryrory@email.comR6r6@abc.com
John
456​
11​
291​
EA
3420​
$ 8.00OR08.2229.22
6701​
684​
0​
2736​
684​
Integrated$ 5,472.00BDebbiedagon@cthulu.comDEde@abc.com
Sarah
562​
12​
293​
EA
540​
$ 4.00OR20.21
8604​
1​
0​
539​
1​
Metal$ 4.00BTonymetal@abc.comTQtq@fakemail.com
Tim
562​
13​
257​
EA
2848​
$ 7.00OR02.2214.22
9360​
300​
0​
2548​
300​
Metal$ 2,100.00BTonymetal@abc.comTQtq@fakemail.com
Scotty
711​
14​
219​
EA
4200​
$ 9.00KY24.21
7817​
62​
0​
4138​
62​
Crown$ 558.00BLindalinda@fakemail.comR6r6@abc.com
Scotty
711​
15​
245​
EA
200​
$ 9.00KY13.22
7765​
126​
0​
74​
126​
Crown$ 1,134.00BLindalinda@fakemail.comR6r6@abc.com
Scotty
711​
16​
294​
EA
6000​
$ 3.00KY13.22
7306​
4479​
0​
1521​
4479​
Crown$ 13,437.00BLindalinda@fakemail.comR6r6@abc.com
Scotty
711​
17​
226​
EA
100​
$ 4.00OR46.21
9080​
4​
0​
96​
4​
Crown$ 16.00BLindalinda@fakemail.comR6r6@abc.com
Scotty
711​
18​
299​
EA
100​
$ 10.00KY03.22
9687​
90​
0​
10​
90​
Crown$ 900.00BLindalinda@fakemail.comR6r6@abc.com
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Sort by date Sort by votes
Here is an image of what the spreadsheet looks like as well.

1669766941616.png
 

Attachments

  • 1669766872922.png
    1669766872922.png
    90.4 KB · Views: 12
Upvote 0
What is the name of the Sheet where this data is posted ?
 
Upvote 0
Hi strangejosh
try this code
VBA Code: 
Sub mailstrangejosh()
'https://www.mrexcel.com/board/threads/vba-script-help-need-to-filter-spreadsheet-by-unique-vendor-and-email-to-corresponding-vendor-then-loop.1223453/

    Dim OutApp As Object, OutMail As Object
    Dim myRng As Range, v As Variant
    Dim j As Long, lastRow As Long
    Dim strbody As String
    
    Application.ScreenUpdating = False

    lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("A2:X" & lastRow).Value
                    
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For j = 2 To UBound(v)
            If Not .exists(v(j, 2)) Then
                .Add v(j, 2), Nothing
                
                strbody = "Hello , " & v(j, 20) & "<br>" & _
                  "Please see below past due order(s) and provide and updated ship week when you can. Thank you" & "<br/><br>"
                
                With ActiveSheet
                    .Range("A1").AutoFilter 2, v(j, 2)
                    Set myRng = .Range("A1:X" & lastRow).SpecialCells(xlCellTypeVisible)
                    
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = v(j, 21)
                        .Subject = v(j, 17) & " - Past Due Orders"
                        .HTMLBody = strbody & RangetoHTML(myRng)
                         .display        'to show
                         '.Send 'to send
                    End With
                End With
            End If
        Next j
      
    End With
    
    Range("A1").AutoFilter
    
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(myRng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim i      As Integer
    
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    myRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    End With
    
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
            
    TempWB.Close savechanges:=False
    
    Kill TempFile
          
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
  
End Function
 
Upvote 0
Solution
Sequoyah said:
Hi strangejosh
try this code
VBA Code: 
Sub mailstrangejosh()
'https://www.mrexcel.com/board/threads/vba-script-help-need-to-filter-spreadsheet-by-unique-vendor-and-email-to-corresponding-vendor-then-loop.1223453/

    Dim OutApp As Object, OutMail As Object
    Dim myRng As Range, v As Variant
    Dim j As Long, lastRow As Long
    Dim strbody As String
   
    Application.ScreenUpdating = False

    lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("A2:X" & lastRow).Value
                   
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For j = 2 To UBound(v)
            If Not .exists(v(j, 2)) Then
                .Add v(j, 2), Nothing
               
                strbody = "Hello , " & v(j, 20) & "<br>" & _
                  "Please see below past due order(s) and provide and updated ship week when you can. Thank you" & "<br/><br>"
               
                With ActiveSheet
                    .Range("A1").AutoFilter 2, v(j, 2)
                    Set myRng = .Range("A1:X" & lastRow).SpecialCells(xlCellTypeVisible)
                   
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = v(j, 21)
                        .Subject = v(j, 17) & " - Past Due Orders"
                        .HTMLBody = strbody & RangetoHTML(myRng)
                         .display        'to show
                         '.Send 'to send
                    End With
                End With
            End If
        Next j
     
    End With
   
    Range("A1").AutoFilter
   
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(myRng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim i      As Integer
   
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
   
    myRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    End With
   
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
           
    TempWB.Close savechanges:=False
   
    Kill TempFile
         
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
 
End Function
Click to expand...
This looks like it will work! Thank you so much. I will have to play with it a bit but I think you got it. I really apprecaite it.
 
Upvote 0
Sequoyah said:
Hi strangejosh
try this code
VBA Code: 
Sub mailstrangejosh()
'https://www.mrexcel.com/board/threads/vba-script-help-need-to-filter-spreadsheet-by-unique-vendor-and-email-to-corresponding-vendor-then-loop.1223453/

    Dim OutApp As Object, OutMail As Object
    Dim myRng As Range, v As Variant
    Dim j As Long, lastRow As Long
    Dim strbody As String
   
    Application.ScreenUpdating = False

    lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("A2:X" & lastRow).Value
                   
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For j = 2 To UBound(v)
            If Not .exists(v(j, 2)) Then
                .Add v(j, 2), Nothing
               
                strbody = "Hello , " & v(j, 20) & "<br>" & _
                  "Please see below past due order(s) and provide and updated ship week when you can. Thank you" & "<br/><br>"
               
                With ActiveSheet
                    .Range("A1").AutoFilter 2, v(j, 2)
                    Set myRng = .Range("A1:X" & lastRow).SpecialCells(xlCellTypeVisible)
                   
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = v(j, 21)
                        .Subject = v(j, 17) & " - Past Due Orders"
                        .HTMLBody = strbody & RangetoHTML(myRng)
                         .display        'to show
                         '.Send 'to send
                    End With
                End With
            End If
        Next j
     
    End With
   
    Range("A1").AutoFilter
   
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(myRng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim i      As Integer
   
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
   
    myRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    End With
   
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
           
    TempWB.Close savechanges:=False
   
    Kill TempFile
         
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
 
End Function
Click to expand...
Hi Sequoyah,

So I noticed that if I filter by Buyer Code in Column V that it will send duplicate emails. One that has blank data and one that has the data. Is there a way to run this script if I am filtered on Buyer Code and not have duplicate emails like the below? Any help would be much apprecaited. Thank you.

Example below when I filter Buyer Code by initals LH.

Hello , Christine
Please see below past due order(s) and provide and updated ship week when you can. Thank you



ENTERED_BYVENDOR_NOSKUUPCEAQUANTITYFOB_COSTDESTINATION_WAREHOUSEREQUESTED_SHIP_WEEKCURRENT_SHIP_COMMIT_WEEKPONUMBERPO_OPEN_QTYSHIPPED_QTYRECEIVED_QTYBalanceCOMMENTSVENDOR_NAMEExt Balance CostCustomVENDOR_CONTACT_INFO.CONTACT_NAMEVENDOR_CONTACT_INFO.CONTACT_EMAIL_ADDRESSSKU_INFO.BUYER_CODERB EmailUpdated Ship Week
 
Upvote 0
Sequoyah said:
Hi strangejosh
try this code
VBA Code: 
Sub mailstrangejosh()
'https://www.mrexcel.com/board/threads/vba-script-help-need-to-filter-spreadsheet-by-unique-vendor-and-email-to-corresponding-vendor-then-loop.1223453/

    Dim OutApp As Object, OutMail As Object
    Dim myRng As Range, v As Variant
    Dim j As Long, lastRow As Long
    Dim strbody As String
   
    Application.ScreenUpdating = False

    lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("A2:X" & lastRow).Value
                   
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For j = 2 To UBound(v)
            If Not .exists(v(j, 2)) Then
                .Add v(j, 2), Nothing
               
                strbody = "Hello , " & v(j, 20) & "<br>" & _
                  "Please see below past due order(s) and provide and updated ship week when you can. Thank you" & "<br/><br>"
               
                With ActiveSheet
                    .Range("A1").AutoFilter 2, v(j, 2)
                    Set myRng = .Range("A1:X" & lastRow).SpecialCells(xlCellTypeVisible)
                   
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = v(j, 21)
                        .Subject = v(j, 17) & " - Past Due Orders"
                        .HTMLBody = strbody & RangetoHTML(myRng)
                         .display        'to show
                         '.Send 'to send
                    End With
                End With
            End If
        Next j
     
    End With
   
    Range("A1").AutoFilter
   
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(myRng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim i      As Integer
   
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
   
    myRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    End With
   
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
           
    TempWB.Close savechanges:=False
   
    Kill TempFile
         
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
 
End Function
Click to expand...
And sorry just one more thing. Even when not filtered by Buyer Code in Column V it does seem to miss the first line or vendor and only sends emails to the remaining 7 unique vendors. Should be 8 total. So in my inital example it misses Vendor_Name - Company and skips right to the next. Not sure why?
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,223,911
Messages
6,175,337
Members
452,637
Latest member
Ezio2866

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top