VBA Code currently showing input box to select cells. I want to pre set the cells and bypass the input box.

[Sphinxy1542]

Help would be much appreciated.
VBA Code currently has input box to select cells. I want to pre-set the cells and bypass the input box so when I open the document it automatically looks at the cells.

Code is as per below:

Private Sub Workbook_Open()
'Updated by Extendoffice 2017/9/14
'Exit Sub
Dim xRgDate As Range
Dim xRgSend As Range
Dim xRgText As Range
Dim xRgDone As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xLastRow As Long
Dim vbCrLf As String
Dim xMailBody As String
Dim xRgDateVal As String
Dim xRgSendVal As String
Dim xMailSubject As String
Dim I As Long
On Error Resume Next
Set xRgDate = Application.InputBox("Please select the due date column:", "KuTools For Excel", , , , , , 8)
If xRgDate Is Nothing Then Exit Sub
Set xRgSend = Application.InputBox("Please select the recipients’ email column:", "KuTools For Excel", , , , , , 8)
If xRgSend Is Nothing Then Exit Sub
Set xRgText = Application.InputBox("Select the column with reminded content in your email:", "KuTools For Excel", , , , , , 8)
If xRgText Is Nothing Then Exit Sub
xLastRow = xRgDate.Rows.Count
Set xRgDate = xRgDate(1)
Set xRgSend = xRgSend(1)
Set xRgText = xRgText(1)
Set xOutApp = CreateObject("Outlook.Application")
For I = 1 To xLastRow
xRgDateVal = xRgDate.Offset(I - 1).Value
If CDate(xRgDateVal) - Date <= 7 And CDate(xRgDateVal) - Date > 0 Then
xRgSendVal = xRgSend.Offset(I - 1).Value
xMailSubject = xRgText.Offset(I - 1).Value & " on " & xRgDateVal
vbCrLf = "

"
xMailBody = "******>"
xMailBody = xMailBody & "Dear " & xRgSendVal & vbCrLf
xMailBody = xMailBody & "Text : " & xRgText.Offset(I - 1).Value & vbCrLf
xMailBody = xMailBody & ""
Set xMailItem = xOutApp.CreateItem(0)
With xMailItem
.Subject = xMailSubject
.To = xRgSendVal
.HTMLBody = xMailBody
.Display
'.Send
End With
Set xMailItem = Nothing
End If
Next
Set xOutApp = Nothing
End Sub

 

[Yongle]

You have not said which ranges are the ones you need so you need to amend to match the sheet's layout
- code below assumes first cell of xRgDate is A2 and that the other data is columns B and C
- amend A2, B and C

Try replacing this

Set xRgDate = Application.InputBox("Please select the due date column:", "KuTools For Excel", , , , , , 8)
If xRgDate Is Nothing Then Exit Sub
Set xRgSend = Application.InputBox("Please select the recipients’ email column:", "KuTools For Excel", , , , , , 8)
If xRgSend Is Nothing Then Exit Sub
Set xRgText = Application.InputBox("Select the column with reminded content in your email:", "KuTools For Excel", , , , , , 8)
If xRgText Is Nothing Then Exit Sub
xLastRow = xRgDate.Rows.Count
Set xRgDate = xRgDate(1)
Set xRgSend = xRgSend(1)
Set xRgText = xRgText(1)

with

Set xRgDate = Range("[COLOR=#ff0000]A[/COLOR]2", Range("[COLOR=#ff0000]A[/COLOR]" & Rows.Count).End(xlUp))
xLastRow = xRgDate.Rows.Count
Set xRgDate = xRgDate(1)
Set xRgSend = Cells(xRgDate.Row, "[COLOR=#ff0000]B[/COLOR]")
Set xRgText = Cells(xRgDate.Row, "[COLOR=#ff0000]C[/COLOR]")

 

[Sphinxy1542]

That's perfect - thank you, I really appreciate your help
I may be taking liberties now, but i'm using this as a 'reminder' for client due dates.
Would you know if its possible for all 'reminders' to show in one email instead of it populating multiple?

 

[Yongle]

That bears no relevance to the title of this thread

I suggest you begin a new thread for that question with a different title and post your latest code there too
Clicking on the # icon immediately above the post window adds code tags
- paste your code between the code tags
(fomats it similar to the way it appears inside the VBA module, and makes it easier to work with)

You will need to explain how you want the strings building
- you cannot have a long list of dates etc in the Subject
- how are text & dates to be aggregated in the Body?

 

[Sphinxy1542]

Many Thanks - Sorry pretty new to this.
I will post a new thread regarding the emails.

I do have another query (Code Below).
The code should be reminding me when an event is less than 30 days away, but it seems to be bringing everything up regardless of date.

thanks Again.

Private Sub Workbook_Open()
'Updated by Extendoffice 2017/9/14
    'Exit Sub
    Dim xRgDate As Range
    Dim xRgSend As Range
    Dim xRgText As Range
    Dim xRgDone As Range
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xLastRow As Long
    Dim vbCrLf As String
    Dim xMailBody As String
    Dim xRgDateVal As String
    Dim xRgSendVal As String
    Dim xMailSubject As String
    Dim I As Long
    On Error Resume Next
    Set xRgDate = Range("A1:A2", Range("A" & Rows.Count).End(xlUp))
xLastRow = xRgDate.Rows.Count
Set xRgDate = xRgDate(1)
Set xRgSend = Cells(xRgDate.Row, "B")
Set xRgText = Cells(xRgDate.Row, "C")
    Set xOutApp = CreateObject("Outlook.Application")
    For I = 1 To xLastRow
        xRgDateVal = xRgDate.Offset(I - 1).Value
        If CDate(xRgDateVal) - Date <= 30 And CDate(xRgDateVal) - Date > 0 Then
            xRgSendVal = xRgSend.Offset(I - 1).Value
            xMailSubject = xRgText.Offset(I - 1).Value & " on " & xRgDateVal
            vbCrLf = "<br><br>"
            xMailBody = "<HTML>******>"
            xMailBody = xMailBody & "Reminder: " & xRgSendVal & vbCrLf
            xMailBody = xMailBody & "Due By : " & xRgText.Offset(I - 1).Value & vbCrLf
            xMailBody = xMailBody & "</BODY></HTML>"
            Set xMailItem = xOutApp.CreateItem(0)
            With xMailItem
                .Subject = xMailSubject
                .To = xRgSendVal
                .HTMLBody = xMailBody
                .Display
                '.Send
            End With
            Set xMailItem = Nothing
        End If
    Next
    Set xOutApp = Nothing
End Sub

 

[Yongle]

Somehow your strings are not matching up (example 5/3/2018 string is not the same as 05/03/2018)
Your date string xRgDateVal is being used elsewhere so I am leaving that unchanged and adding 2 new variables to make the IF test work
Both variables are being declared as Long which means that they carry both date values as whole numbers
The logic of the code is unchanged
In case you are wondering =Today() is a function in Excel but not in VBA, so it is a permitted variable name

1. Declare these variables with your other variables

Dim rowDate As Long, today As Long

2. Replace this line

If CDate(xRgDateVal) - Date <= 30 And CDate(xRgDateVal) - Date > 0 Then

with

today = Date  
rowDate = xRgDate.Offset(I - 1).Value
If rowDate - today <= 30 And rowDate - today > 0 Then

 

[Sphinxy1542]

Thanks Yongle, I've added as per below but now it won't activate at all. Slightly confused.
I was only adding the variable and not removing another wasn't i?

Private Sub Workbook_Open()
'Updated by Extendoffice 2017/9/14
    'Exit Sub
    Dim xRgDate As Range
    Dim xRgSend As Range
    Dim xRgText As Range
    Dim xRgDone As Range
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xLastRow As Long
    Dim vbCrLf As String
    Dim xMailBody As String
    Dim xRgDateVal As String
    Dim xRgSendVal As String
    Dim xMailSubject As String
    Dim I As Long
    Dim rowDate As Long, today As Long
    On Error Resume Next
    Set xRgDate = Range("A1:A2", Range("A" & Rows.Count).End(xlUp))
xLastRow = xRgDate.Rows.Count
Set xRgDate = xRgDate(1)
Set xRgSend = Cells(xRgDate.Row, "B")
Set xRgText = Cells(xRgDate.Row, "C")
    Set xOutApp = CreateObject("Outlook.Application")
    For I = 1 To xLastRow
        xRgDateVal = xRgDate.Offset(I - 1).Value
        Itoday = Date
        rowDate = xRgDate.Offset(I - 1).Value
        If rowDate - today <= 30 And rowDate - today > 0 Then
            xRgSendVal = xRgSend.Offset(I - 1).Value
            xMailSubject = xRgText.Offset(I - 1).Value & " on " & xRgDateVal
            vbCrLf = ""
            xMailBody = "******>"
            xMailBody = xMailBody & "Reminder: " & xRgSendVal & vbCrLf
            xMailBody = xMailBody & "Due By : " & xRgText.Offset(I - 1).Value & vbCrLf
            xMailBody = xMailBody & ""
            Set xMailItem = xOutApp.CreateItem(0)
            With xMailItem
                .Subject = xMailSubject
                .To = xRgSendVal
                .HTMLBody = xMailBody
                .Display
                '.Send
            End With
            Set xMailItem = Nothing
        End If
    Next
    Set xOutApp = Nothing
End Sub

 

[Yongle]

Option Explicit

placed at the very top of the module would have made VBA alert you to a typo
- add it and run the code before you make the correction
- it forces all variables to be declared and any mistyped ones are deemed undeclared and brought to your attention

you have inadvertently added a rogue letter

   [COLOR=#ff0000]I[/COLOR]today = Date

 

[Sphinxy1542]

All amended and Option Explicit now set, but still not working.
Is their anything else you can thing of which would cause a problem?

 

[Yongle]

The problem is caused because the test is not doing what you want.

Check generated values to establish why the test is not working

After

[COLOR=#333333]rowDate = xRgDate.Offset(I - 1).Value[/COLOR]

Add these lines

MsgBox 1 & vbCr & rowDate
MsgBox 2 & vbCr & today
MsgBox 3 & vbCr & rowDate - today

run the code and the 3 message boxes should help you work out what is wrong

why is the test failing?