Amend VBA code for date to appear in email subject and attachment

[exceluser9]

Hi Team,

Im using below VBA code to create a excel attachment along with an outlook email

I need the code to be amended. What i want is along with the subject "Back orders report" i want todays date and the data which is present in A3 and also i want the file also to be saved with the name "Back orders report" along with date and A3 in the email which is triggering

Please could you help?
Thanks in advance

Below is the VBA code

Sub Buyer_HU()
Dim c As Range, sh As Worksheet, Ky As Variant, dam As Variant, dict As Object
Dim correo As String, lr As Long, wFile As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set sh = Sheets("Template")
If sh.AutoFilterMode Then sh.AutoFilterMode = False
lr = sh.Range("A" & Rows.Count).End(xlUp).Row
sh.Range("BA:BA").ClearContents
For Each c In sh.Range("A2", sh.Range("A" & Rows.Count).End(xlUp))
sh.Range("BA" & c.Row) = c & sh.Range("M" & c.Row) & sh.Range("M" & c.Row)
Next
Set dict = CreateObject("scripting.dictionary")
For Each c In sh.Range("BA2", sh.Range("BA" & Rows.Count).End(xlUp))
dict.Item(c.Value) = sh.Range("M" & c.Row)
Next
For Each Ky In dict.Keys
correo = dict(Ky)
sh.Range("A1:BA" & lr).AutoFilter Columns("BA").Column, Ky
sh.Range("A1:BA" & lr).AutoFilter Columns("BA").Column, Ky, xlOr, " ", True
'ActiveSheet.Range("$A$1:$BA$2000").AutoFilter 53
Workbooks.Add
sh.AutoFilter.Range.EntireRow.Copy Range("A1")
Dim wcc
wcc = Range("AY1")
Range("BA:BA").ClearContents
wFile = ThisWorkbook.Path & "\Back orders report.xlsx"
Cells.Select
Selection.Columns.AutoFit
ActiveWorkbook.SaveAs wFile
ActiveWorkbook.Close False
Set dam = CreateObject("Outlook.Application").CreateItem(0)
With dam
.SentOnBehalfOfName = wcc
'.Bodyformat = olFormatHTML
.To = correo
.cc = ""
.Subject = "Supplier induct status update only"
.HTMLBody = "Good Morning," & "<br>" & "<br>" & "Please see attached for today's reports." & "<br>" & "<br>" & "Please use the below coding:" & "<br>" & "<br>" & "07/12/2030 - means call off order" & "<br>" & "<br>" & "Thank you for your support in advance." & "<br>" & "<br>" & "Thanks and Regards," & "<br>" & "Supplier Induct Team"
.Attachments.Add wFile
.Display 'use .Send to send
End With
Next Ky
'sh.ShowAllData
'Selection.AutoFilter
Columns("BA:BA").Select
Selection.Delete Shift:=xlToLeft
MsgBox "Emails generated"
Range("A2").Select
End Sub

 

[Sparcot]

Hello. Untested.

Sub Buyer_HU()
    Dim c As Range, sh As Worksheet, Ky As Variant, dam As Variant, dict As Object
    Dim correo As String, lr As Long, wFile As String
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set sh = Sheets("Template")
    If sh.AutoFilterMode Then sh.AutoFilterMode = False
    lr = sh.Range("A" & Rows.Count).End(xlUp).Row
    sh.Range("BA:BA").ClearContents
    For Each c In sh.Range("A2", sh.Range("A" & Rows.Count).End(xlUp))
        sh.Range("BA" & c.Row) = c & sh.Range("M" & c.Row) & sh.Range("M" & c.Row)
    Next
    Set dict = CreateObject("scripting.dictionary")
    For Each c In sh.Range("BA2", sh.Range("BA" & Rows.Count).End(xlUp))
        dict.Item(c.Value) = sh.Range("M" & c.Row)
    Next
    For Each Ky In dict.Keys
        correo = dict(Ky)
        sh.Range("A1:BA" & lr).AutoFilter Columns("BA").Column, Ky
        sh.Range("A1:BA" & lr).AutoFilter Columns("BA").Column, Ky, xlOr, " ", True
        'ActiveSheet.Range("$A$1:$BA$2000").AutoFilter 53
        Workbooks.Add
        sh.AutoFilter.Range.EntireRow.Copy Range("A1")
        Dim wcc
        wcc = Range("AY1")
        Range("BA:BA").ClearContents
        wFile = ThisWorkbook.Path & "\Back orders report " & Format(Now(), "dd.mm.yyyy") & "_" & sh.Range("A3").Value & ".xlsx" '<== Changes here
        Cells.Select
        Selection.Columns.AutoFit
        ActiveWorkbook.SaveAs wFile
        ActiveWorkbook.Close False
        Set dam = CreateObject("Outlook.Application").CreateItem(0)
        With dam
            .SentOnBehalfOfName = wcc
            '.Bodyformat = olFormatHTML
            .To = correo
            .cc = ""
            .Subject = "Back orders report " & Format(Now(), "dd.mm.yyyy") & "_" & sh.Range("A3").Value '<== Changes here
            .HTMLBody = "Good Morning," & "<br>" & "<br>" & "Please see attached for today's reports." & "<br>" & "<br>" & "Please use the below coding:" & "<br>" & "<br>" & "07/12/2030 - means call off order" & "<br>" & "<br>" & "Thank you for your support in advance." & "<br>" & "<br>" & "Thanks and Regards," & "<br>" & "Supplier Induct Team"
            .Attachments.Add wFile
            .Display 'use .Send to send
        End With
    Next Ky
    'sh.ShowAllData
    'Selection.AutoFilter
    Columns("BA:BA").Select
    Selection.Delete Shift:=xlToLeft
    MsgBox "Emails generated"
    Range("A2").Select
End Sub

 

[exceluser9]

Hi Sparcot,

Thank you for your reply,

This code works fine. However, there is one glitch. The value of A3 is picking from the master file. However, it should pick the A3 data from the new file which is generating and saving in the email

Please help

Thanks in advance

 

[Sparcot]

Give it a try:

Sub Buyer_HU()
    Dim c As Range, sh As Worksheet, Ky As Variant, dam As Variant, dict As Object
    Dim correo As String, lr As Long, wFile As String
    Dim tempData As String '<== Changes here
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set sh = Sheets("Template")
    If sh.AutoFilterMode Then sh.AutoFilterMode = False
    lr = sh.Range("A" & Rows.Count).End(xlUp).Row
    sh.Range("BA:BA").ClearContents
    For Each c In sh.Range("A2", sh.Range("A" & Rows.Count).End(xlUp))
        sh.Range("BA" & c.Row) = c & sh.Range("M" & c.Row) & sh.Range("M" & c.Row)
    Next
    Set dict = CreateObject("scripting.dictionary")
    For Each c In sh.Range("BA2", sh.Range("BA" & Rows.Count).End(xlUp))
        dict.Item(c.Value) = sh.Range("M" & c.Row)
    Next
    For Each Ky In dict.Keys
        correo = dict(Ky)
        sh.Range("A1:BA" & lr).AutoFilter Columns("BA").Column, Ky
        sh.Range("A1:BA" & lr).AutoFilter Columns("BA").Column, Ky, xlOr, " ", True
        'ActiveSheet.Range("$A$1:$BA$2000").AutoFilter 53
        Workbooks.Add
        sh.AutoFilter.Range.EntireRow.Copy Range("A1")
        Dim wcc
        wcc = Range("AY1")
        Range("BA:BA").ClearContents
        Cells.Select
        Selection.Columns.AutoFit
        tempData = ActiveSheet.Range("A3").Value '<== Changes here
        wFile = ThisWorkbook.Path & "\Back orders report " & Format(Now(), "dd.mm.yyyy") & "_" & tempData & ".xlsx" '<== Changes here
        ActiveWorkbook.SaveAs wFile
        ActiveWorkbook.Close False
        Set dam = CreateObject("Outlook.Application").CreateItem(0)
        With dam
            .SentOnBehalfOfName = wcc
            '.Bodyformat = olFormatHTML
            .To = correo
            .cc = ""
            .Subject = "Back orders report " & Format(Now(), "dd.mm.yyyy") & "_" & tempData '<== Changes here
            .HTMLBody = "Good Morning," & "<br>" & "<br>" & "Please see attached for today's reports." & "<br>" & "<br>" & "Please use the below coding:" & "<br>" & "<br>" & "07/12/2030 - means call off order" & "<br>" & "<br>" & "Thank you for your support in advance." & "<br>" & "<br>" & "Thanks and Regards," & "<br>" & "Supplier Induct Team"
            .Attachments.Add wFile
            .Display 'use .Send to send
        End With
    Next Ky
    'sh.ShowAllData
    'Selection.AutoFilter
    Columns("BA:BA").Select
    Selection.Delete Shift:=xlToLeft
    MsgBox "Emails generated"
    Range("A2").Select
End Sub

 

[exceluser9]

This is working amazingly, thank you so much for your help

 

[exceluser9]

Hi Team,

I would require one more amendment to the code

Can the macro copy the table and paste in the body of the email instead of creating the attachment?