shahzeb123
Board Regular
- Joined
- Jul 29, 2021
- Messages
- 62
- Office Version
- 2016
- Platform
- Windows
Hi Guys
Good to be back
I have one sheet which actually a check list for banks KYC/DD documents which is made according to coutnries. Therefore, in one workbook it can have 20 sheet or 19.
What i want is VBA to go through the whole sheet compare the today() formula to column J of every sheet and if any date has less then 7 days difference or already passed then it should pick up the same line column C (which wll be the document name ) and sent an email xxx.com the subject should be the bank name which is written on D6 on everey sheet.
I have very high hopes from u guys, please HELP !!!!
i have extracted following code from internet but it did not serve the purpose;;
Public Sub SendReminderMail()
'Declare the variables
Dim XDueDate As Range
Dim XRcptsEmail As Range
Dim xMailContent As Range
Dim xRngDn As Range
Dim xCrtOut As Object
Dim xValDateRng As String
Dim xValSendRng As String
Dim k As Long
Dim xMailSections As Object
Dim xFinalRw As Long
Dim CrVbLf As String
Dim xMsg As String
Dim xSubEmail As String
On Error Resume Next
'To select the date column insert a input box
Set XDueDate = Application.InputBox("Select the column for Deadline/Due Date date column:", "ExcelDemy", , , , , , 8)
If XDueDate Is Nothing Then Exit Sub
'Insert a input box for selecting the recipients
Set XRcptsEmail = Application.InputBox("Choose the column for the email addresses of the recipients:", "ExcelDemy", , , , , , 8)
If XRcptsEmail Is Nothing Then Exit Sub
'To enter the text mail, insert a input box
Set xMailContent = Application.InputBox("In your email, choose the column with the reminded text:", "ExcelDemy", , , , , , 8)
If xMailContent Is Nothing Then Exit Sub
'Count rows for the due dates
xFinalRw = XDueDate.Rows.Count
Set XDueDate = XDueDate(1)
Set XRcptsEmail = XRcptsEmail(1)
Set xMailContent = xMailContent(1)
'Set command to open MS Outlook Application
Set xCrtOut = CreateObject("Outlook.Application")
'Apply For loop to conduct the operation in each row one by one
For k = 1 To xFinalRw
xValDateRng = ""
xValDateRng = XDueDate.Offset(k - 1).Value
'Apply If condition for the Due Date values
If xValDateRng <> "" Then
'Condition set to send mail if the difference between due dates and current date is greater than 1 and less than 7 days
'Means 1 < X< 7, X = Due Date - Current Date
If CDate(xValDateRng) - Date <= 7 And CDate(xValDateRng) - Date > 0 Then
xValSendRng = XRcptsEmail.Offset(k - 1).Value
'Create the subject, body and text contents with the required variables
xSubEmail = xMailContent.Offset(k - 1).Value & " on " & xValDateRng
CrVbLf = "<br><br>"
xMsg = "<HTML><BODY>"
xMsg = xMsg & "Dear " & xValSendRng & CrVbLf
xMsg = xMsg & "Text : " & xMailContent.Offset(k - 1).Value & CrVbLf
xMsg = xMsg & "</BODY></HTML>"
'Create the email
Set xMailSections = xCrtOut.CreateItem(0)
'Define the position to place the Subject, Body and Recipients Address
With xMailSections
.Subject = xSubEmail
.To = xValSendRng
.HTMLBody = xMsg
.Display
.Send
End With
Set xMailSections = Nothing
End If
End If
Next
Set xCrtOut = Nothing
End Sub
Good to be back
I have one sheet which actually a check list for banks KYC/DD documents which is made according to coutnries. Therefore, in one workbook it can have 20 sheet or 19.
What i want is VBA to go through the whole sheet compare the today() formula to column J of every sheet and if any date has less then 7 days difference or already passed then it should pick up the same line column C (which wll be the document name ) and sent an email xxx.com the subject should be the bank name which is written on D6 on everey sheet.
I have very high hopes from u guys, please HELP !!!!
i have extracted following code from internet but it did not serve the purpose;;
Public Sub SendReminderMail()
'Declare the variables
Dim XDueDate As Range
Dim XRcptsEmail As Range
Dim xMailContent As Range
Dim xRngDn As Range
Dim xCrtOut As Object
Dim xValDateRng As String
Dim xValSendRng As String
Dim k As Long
Dim xMailSections As Object
Dim xFinalRw As Long
Dim CrVbLf As String
Dim xMsg As String
Dim xSubEmail As String
On Error Resume Next
'To select the date column insert a input box
Set XDueDate = Application.InputBox("Select the column for Deadline/Due Date date column:", "ExcelDemy", , , , , , 8)
If XDueDate Is Nothing Then Exit Sub
'Insert a input box for selecting the recipients
Set XRcptsEmail = Application.InputBox("Choose the column for the email addresses of the recipients:", "ExcelDemy", , , , , , 8)
If XRcptsEmail Is Nothing Then Exit Sub
'To enter the text mail, insert a input box
Set xMailContent = Application.InputBox("In your email, choose the column with the reminded text:", "ExcelDemy", , , , , , 8)
If xMailContent Is Nothing Then Exit Sub
'Count rows for the due dates
xFinalRw = XDueDate.Rows.Count
Set XDueDate = XDueDate(1)
Set XRcptsEmail = XRcptsEmail(1)
Set xMailContent = xMailContent(1)
'Set command to open MS Outlook Application
Set xCrtOut = CreateObject("Outlook.Application")
'Apply For loop to conduct the operation in each row one by one
For k = 1 To xFinalRw
xValDateRng = ""
xValDateRng = XDueDate.Offset(k - 1).Value
'Apply If condition for the Due Date values
If xValDateRng <> "" Then
'Condition set to send mail if the difference between due dates and current date is greater than 1 and less than 7 days
'Means 1 < X< 7, X = Due Date - Current Date
If CDate(xValDateRng) - Date <= 7 And CDate(xValDateRng) - Date > 0 Then
xValSendRng = XRcptsEmail.Offset(k - 1).Value
'Create the subject, body and text contents with the required variables
xSubEmail = xMailContent.Offset(k - 1).Value & " on " & xValDateRng
CrVbLf = "<br><br>"
xMsg = "<HTML><BODY>"
xMsg = xMsg & "Dear " & xValSendRng & CrVbLf
xMsg = xMsg & "Text : " & xMailContent.Offset(k - 1).Value & CrVbLf
xMsg = xMsg & "</BODY></HTML>"
'Create the email
Set xMailSections = xCrtOut.CreateItem(0)
'Define the position to place the Subject, Body and Recipients Address
With xMailSections
.Subject = xSubEmail
.To = xValSendRng
.HTMLBody = xMsg
.Display
.Send
End With
Set xMailSections = Nothing
End If
End If
Next
Set xCrtOut = Nothing
End Sub
