Struggling with VBA Script

[Newbie_Nat]

Hello
I am very new to using VBA scripts! Customer has asked for an automated email using data from a worksheet. This is for holiday requests, so the row will change when a new request is submitted. I have managed to get the following to work to some extent, but not all info is being pulled successfully to the email:

Dim xRg As Range
'Update by Extendoffice 2018/3/7
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
  Set xRg = Intersect(Range("M5:M20"), Target)
    If xRg Is Nothing Then Exit Sub
    If Target.Value > 0 Then
        Call Mail_small_Text_Outlook
    End If
End Sub
Sub Mail_small_Text_Outlook()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Please accept this email as confirmation of your holiday booking - information as below" & vbNewLine & vbNewLine & _
    "Date of Request: " & Str(Sheet1.Cells(5, 6)) & vbNewLine & _
    "Number of Days Booked:" & Str(Sheet1.Cells(5, 5)) & vbNewLine & vbNewLine & _
              "2021 Leave Remaining as at today's date:" & Str(Sheet1.Cells(5, 8)) & " days" & vbNewLine & _
              "Data Entered By:" & vbNewLine & vbNewLine & _
              "Authorised By:" & Str(Sheet1.Cells(5, 7)) & vbNewLine & vbNewLine & _
              "Thank you"
    On Error Resume Next
    With xOutMail
        .To = "****@******.com"
        .CC = ""
        .BCC = ""
        .Subject = "Holiday Booking Confirmation"
        .Body = xMailBody
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

Authorised by is entered in the spreadhseet as NP 06/01/2021 - this is being pulled as 0 in the email. I've tried different types of cell formatting but to no avail.
Data Entered by - this is initials only and is the trigger cell for the email. Nothing is being pulled to the email at all.

I hope I've given enough information for someone to help!?

Many thanks in advance

 

[dmt32]

Hi
try this update to the xmailbody part of your code

xMailBody = "Please accept this email As confirmation of your holiday booking - information As below" & vbNewLine & vbNewLine & _
                "Date of Request: " & CStr(Sheet1.Cells(5, 6).Text) & vbNewLine & _
                "Number of Days Booked:" & CStr(Sheet1.Cells(5, 5).Text) & vbNewLine & vbNewLine & _
                "2021 Leave Remaining As at  today 's date:" & CStr(Sheet1.Cells(5, 8).Text) & " days" & vbNewLine & _
                "Data Entered By:" & CStr(Sheet1.Cells(5, 7).Text) & vbNewLine & vbNewLine & _
                "Authorised By:" & CStr(Sheet1.Cells(5, 7).Text) & vbNewLine & vbNewLine & _
                "Thank you"

You had no cell reference for Data Entered By - change range shown in BOLD as required

Hope Helpful

Dave

 

[Newbie_Nat]

Dave - thanks very much, that worked perfectly!

I suppose my next question is how do I get the script to automatically go to the next row when another holiday request is entered? Rather than have to manually change the script? There are 34 employees, so really want to avoid have to change the script manually!

Hope that makes sense?

Many thanks,
Nat

 

[dmt32]

Dave - thanks very much, that worked perfectly!

I suppose my next question is how do I get the script to automatically go to the next row when another holiday request is entered? Rather than have to manually change the script? There are 34 employees, so really want to avoid have to change the script manually!

Hope that makes sense?

Many thanks,
Nat

Pleased update helped.
Probably different question but one idea would be to pass the row number as an argument from the calling procedure

'Updated 2021/1/8
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
  Set xRg = Intersect(Range("M5:M20"), Target)
    If xRg Is Nothing Then Exit Sub
    If Target.Value > 0 Then
        Call Mail_small_Text_Outlook(Target.Row)
    End If
End Sub

Sub Mail_small_Text_Outlook(ByVal TargetRow As Long)
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
  
    xMailBody = "Please accept this email As confirmation of your holiday booking - information As below" & vbNewLine & vbNewLine & _
                "Date of Request: " & CStr(Sheet1.Cells(TargetRow, 6).Text) & vbNewLine & _
                "Number of Days Booked:" & CStr(Sheet1.Cells(TargetRow, 5).Text) & vbNewLine & vbNewLine & _
                "2021 Leave Remaining As at today's date:" & CStr(Sheet1.Cells(TargetRow, 8).Text) & " days" & vbNewLine & _
                "Data Entered By:" & CStr(Sheet1.Cells(TargetRow, 7).Text) & vbNewLine & vbNewLine & _
                "Authorised By:" & CStr(Sheet1.Cells(TargetRow, 7).Text) & vbNewLine & vbNewLine & _
                "Thank you"
  
    On Error Resume Next
    With xOutMail
        .To = "****@******.com"
        .CC = ""
        .BCC = ""
        .Subject = "Holiday Booking Confirmation"
        .Body = xMailBody
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

see if this does what you want - don't forget tp update range shown in bold to correct cell address

Dave

 

[Newbie_Nat]

@dmt32 - Again, worked perfectly, thank you so much!
Just need to create 34 of them now!

 

[dmt32]

@dmt32 - Again, worked perfectly, thank you so much!
Just need to create 34 of them now!

Glad suggestion works for you
Not sure what you mean by last comment?

Dave

 

[Newbie_Nat]

There are 34 employees each with their own worksheet - so I'll copy & paste and change the sheet number........

 

[dmt32]

There are 34 employees each with their own worksheet - so I'll copy & paste and change the sheet number........

Helpful if you had stated that

- you just update to make it a common code


Place in a standard Module

Sub Mail_small_Text_Outlook(ByVal Target As Range)
    Dim xOutApp As Object, xOutMail As Object
    Dim xMailBody As String
    Dim ws As Worksheet
    
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    Set ws = Target.Parent
    
    xMailBody = "Please accept this email As confirmation of your holiday booking - information As below" & vbNewLine & vbNewLine & _
                "Date of Request: " & CStr(ws.Cells(Target.Row, 6).Text) & vbNewLine & _
                "Number of Days Booked:" & CStr(ws.Cells(Target.Row, 5).Text) & vbNewLine & vbNewLine & _
                "2021 Leave Remaining As at today's date:" & CStr(ws.Cells(Target.Row, 8).Text) & " days" & vbNewLine & _
                "Data Entered By:" & CStr(ws.Cells(Target.Row, 7).Text) & vbNewLine & vbNewLine & _
                "Authorised By:" & CStr(ws.Cells(Target.Row, 7).Text) & vbNewLine & vbNewLine & _
                "Thank you"
   
    On Error Resume Next
    With xOutMail
        .To = "****@******.com"
        .CC = ""
        .BCC = ""
        .Subject = "Holiday Booking Confirmation"
        .Body = xMailBody
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

If you are using Worksheet_Change event in each sheet to call the code??

Then delete them & place following in the Thisworkbook Code Page

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Range("M5:M20"), Target) Is Nothing Then
        If Len(Target.Value) > 0 Then Call Mail_small_Text_Outlook(Target)
    End If
End Sub

This code will trigger for all worksheets in your workbook - if there are sheets you need to exclude let me know & will update code

Dave

 

[Newbie_Nat]

@dmt32 - Apologies! Thanks, I'll add that. No sheets to exclude, so all good.

The other thing I was going to ask - is there a way to add the holiday detail to an O365 calendar, both individual and a shared?

Thanks again

 

[dmt32]

@dmt32 - Apologies! Thanks, I'll add that. No sheets to exclude, so all good.

The other thing I was going to ask - is there a way to add the holiday detail to an O365 calendar, both individual and a shared?

Thanks again

Probably but is a new question - suggest start another thread

Good luck with project

Dave