i have a excel list and and i want to make a button to send an email in the list using template, the target email address is in column K, but i only want to send it if column A is showing YES.
I wrote a script to loop every row i want and see if column A has "YES" or not, if yes then refer to another macro.
but i got stuck in anther macro, i cant specify .to = column K
Here is the loop script to find if column A has YES:
sub agreement2 ()
dim startrow as integer
startrow = 9
dim mylastrow3 as integer
lastrow3 = activesheet.cells(rows.count, 1).end(xlup).row
dim i as integer
for i = 9 to lastrow3
if (cells(i, 1).value = "YES") then
send_letter
end if
end sub
Here is my send_letter script
Sub send_letter()
Dim Subject
Dim Body
Dim otlapp As Object
Dim olMail2 As Object
Dim ws As Object
Set otlapp = CreateObject("Outlook.Application")
Set olMail2 = otlapp.CreateItemFromTemplate("\\cpadm001.corp.ocalwa.com\clk\DEPT\CLKDEPT6\IMT\SAO\SSC\Team\Team1\New Joiner Script\agreement.oft")
Set doc2 = olMail2.GetInspector.WordEditor
Set ws = ThisWorkbook.Worksheets("Send Letters")
vTemplateBody2 = olMail2.HTMLBody
Subject2 = "Agreement Letter"
HTMLBody2 = vTemplateBody2
With olMail2
.To = ????????????????.Value
.Subject = Subject2
Set WrdRng = doc2.Range
WrdRng.Paste
.Send
End With
End Sub
Could anyone help with the column K thing. thank you so much.
Change send_letter to send_letter(r)
Alter call from send_letter to send_letter i
Your final code will be: .To = Cells(r, "K").Value
Related
I would definitely be considered a vba beginner, and I am trying to build into my project management spreadsheet an automatic email reminder when today's date falls within 4 days of a due date. But the code I'm using keeps returning a runtime error 13: type mismatch.
I have searched the hallowed halls of the entire internet looking for this solution but nothing seems to match my specific problem, or maybe I'm just having trouble applying the principles in other posts to this specific code.
Here is the code.
Option Explicit
Sub email()
Dim r As Range
Dim cell As Range
Set r = Range("D4:D154")
For Each cell In r
If r.Value <= (Date + 4) And r.Value >= (Date + 0) Then
Dim Email_Subject, Email_Send_From, Email_Send_To, _
Email_Cc, Email_Bcc, Email_Body As String
Dim Mail_Object, Mail_Single As Variant
Email_Subject = ActiveCell(0, 2) & ActiveCell(0, -2) & "is due"
Email_Send_From = "me#domain.com"
Email_Send_To = Cells(1, 11)
Email_Body = "This is an automated reminder to update BSA Project Manager on your project."
On Error GoTo debugs
Set Mail_Object = CreateObject("Outlook.Application")
Set Mail_Single = Mail_Object.CreateItem(0)
With Mail_Single
.Subject = Email_Subject
.To = Email_Send_To
.Body = Email_Body
.send
End With
End If
Next
The error is being returned on the If r.value <= (date+4) line. I included the entire code both for context and for if anyone in passing sees anything else I did that was wrong, that it may be pointed out if you are so inclined.
I have attempted to use DateDiff as well with the same result. I'm thinking that maybe I shouldn't set Dim r as Range, or maybe I should be using some language to let excel know that what is in each cell in the D column is a date so that the data types match.
Forgive me if this is an idiot question.
Cleaning up and simplifying this code a bit - here are a few points to consider:
When declaring variables one after the other, you need to specify their type for each of the variables declared: Dim Email_Subject As String, Dim Email_Send_From As String, etc. - otherwise only the last is declared As String and the rest are Variants.
It's best practice to explicitly declare which Workbook and Worksheet you are working with when referencing a Range - so specify which worksheet Range("D4:D154") is on.
Your TYPE MISMATCH error is from trying to compare r.Value to (Date + 4), instead of cell.Value - you're looping through each cell after all.
Instead of using ActiveCell in your loop, just use cell and then Offset to refer to a column to the right or to the left.
So your modified code might look something like this: (UNTESTED)
Sub email()
Dim r As Range, cell As Range
Dim ws As Worksheet
Dim Mail_Object As Object, Mail_Single As Object
Dim Email_Subject As String, Email_Send_From As String, Email_Send_To As String, _
Email_Cc As String, Email_Bcc As String, Email_Body As String
Set ws = ThisWorkbook.Worksheets("Sheet1") ' change to your sheet name
Set r = ws.Range("D4:D154")
Set Mail_Object = CreateObject("Outlook.Application")
For Each cell In r
If cell.Value <= (Date + 4) And cell.Value >= (Date) Then
Email_Subject = cell.Offset(, 1).Value & cell.Offset(, -1).Value & "is due"
Email_Send_From = "me#domain.com"
Email_Send_To = ws.Cells(1, 11).Value
Email_Body = "This is an automated reminder to update BSA Project Manager on your project."
On Error GoTo debugs
Set Mail_Single = Mail_Object.CreateItem(0)
With Mail_Single
.Subject = Email_Subject
.To = Email_Send_To
.Body = Email_Body
.Send
End With
End If
Next cell
'... more code
End Sub
I want to create an Excel file where people can enter their E-Mail address and as soon as 5 People added their E-Mail an Message is sent to all those E-Mails.
To execute the VBA-Makro when saving i do the following:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'My Code is here
End Sub
I try to loop over one column but didn't found a good solution for this - currently I have set a Rage from B2 to B99
I need to get the E-Mail from the cell, ignore empty/null cells and I need to somehow check the E-Mail if its valid (RegEx?)
Dim eMailList As String
Dim eMailCount As Integer
eMailCount = 0
eMailList = ""
Dim eMail As String
Dim rng As Range: Set rng = ThisWorkbook.Worksheets("Tabelle1").Range("B2:B99")
Dim i As Integer
For i = 1 To rng.Rows.Count
eMail = rng.Cells(RowIndex:=i, ColumnIndex:="B").Text
eMailList = eMailList & eMail & "; "
Next
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = eMailList
.Subject = "DummyText"
.Body = "DummyText"
.send
End With
My Questions are:
How can I easy iterate over the cells in one specific Column?
How can I get the eMail from the cell - .Text .Value?
How to use Regular Expressions in VBA/Excel to validate Email?
How can I list the EMails and send a message to each E-Mail
Im glad for any help/tip/recommendation
Thanks in Advance
The code below will get you started, explanations inside the codes comments:
Dim Rng As Range, C As Range
Set Rng = ThisWorkbook.Worksheets("Tabelle1").Range("B2:B99")
' loop through all cells in Range (Column "B")
For Each C In Rng
If Trim(C.Value2) <> "" Then ' <-- check that cell isn't empty
' --- Add Here another IF criteria to validate your E-Mail ---
eMail = Rng.Value2 ' <-- read the value2 of the cell (without the cell's format)
eMailList = eMailList & eMail & "; "
End If
Next C
I want to make an editable email template where everyone can update the email and assign to which user they want to sent which email. The email templates are from another sheet. Every template has its own email ID.
I want to match the template with the table that contain all of the information needed. So, whenever user input the email ID, it will mapped the value with thee placeholder in the email template.
So far, here is what I have been working on with the email template. But right now it just grab all of the value from the cell. Which is breakable whenever I add columns or rows.
Sub Mail_with_outlook2()
Dim mainWB As Workbook
Dim otlApp As Object
Dim olMail As Object
Dim olMailItem As Object
Dim Doc As Object
Dim SendID
Dim CCID
Dim Subject
Dim Body
Dim WrdRng As Object
Dim result
Dim i As Long
Set otlApp = CreateObject("Outlook.Application")
Set olMail = otlApp.CreateItem(0)
Set mainWB = ActiveWorkbook
SendID = mainWB.Sheets("Email Template").Range("C3").Value
CCID = mainWB.Sheets("Email Template").Range("D3").Value
Subject = mainWB.Sheets("Email Template").Range("E3").Value
Body = mainWB.Sheets("Email Template").Range("F3").Value
Dim splitBody
splitBody = Split(Body, "<%")
For i = 0 To UBound(splitBody)
result = Replace(Body, ">", "K")
Next i
With olMail
.to = SendID
If CCID <> "" Then
.CC = CCID
End If
.Subject = Subject
.Display
End With
Set Doc = olMail.GetInspector.WordEditor
Set WrdRng = Doc.Range(Start:=0, End:=0)
WrdRng.Select
mainWB.Sheets("Email Template").Range("F3").Copy
WrdRng.Paste
MsgBox ("you Mail has been sent to " & SendID)
End Sub
Table + Match function
Consider turning your template sheet data into Excel Table. Then you can use the "table object" aka. ListObject to refer to it's columns by their name (column headings).
To find the relative position of the ID inside the table, you can use WorksheetFunction.Match.
Code with examples
In my code, the sheet where the parameters for the mail template are is called "IssueTemplates".
The table is called "IssueTemplatesTable".
Sub GetDataFromTable()
Dim IssueTemplatesTable As ListObject
Dim ID_Searched As Integer 'Input variable
Dim ID_RelativeRow As Integer 'Input relative row inside the table
Dim Var1 As String 'Output variable
Set IssueTemplatesTable = ThisWorkbook.Sheets("IssueTemplates").ListObjects("IssueTemplatesTable")
'''''''''''''''''EXAMPLE 1'''''''''''''''''''''''''
ID_Searched = 17 'Input: "No" of template
With IssueTemplatesTable
ID_RelativeRow = WorksheetFunction.Match(ID_Searched, .ListColumns("No").DataBodyRange, 0)
Var1 = .DataBodyRange(ID_RelativeRow, .ListColumns("Issue Type").Index)
End With 'IssueTemplatesTable
MsgBox Var1 'Output: "Others"
'''''''''''''''''EXAMPLE 2'''''''''''''''''''''''''
ID_Searched = 25 'Input: "No" of template
With IssueTemplatesTable
ID_RelativeRow = WorksheetFunction.Match(ID_Searched, .ListColumns("No").DataBodyRange, 0)
Var1 = .DataBodyRange(ID_RelativeRow, .ListColumns("Issue Type").Index)
End With 'IssueTemplatesTable
MsgBox Var1 'Output: "Mapping"
End Sub
I have images that I have assigned macros to in a worksheet and am trying to apply parameters to ensure that only valid entries are made. The spin button increase or decrease a cell value by a value of 1 on each click. I have used data validation criteria to only allow for values of 2 or greater (to avoid negative values, which don't exist, as well as using invalid references), but this only limits value entries when I type them in manually and is not firing when the buttons are used to decrease the values.
Is there a way to apply a sort of
.Min
.Max
function to these shape-buttons? I basically just do not want the user to be able to enter values below 2. Thanks!
Current Code:
Sub Increase_Val()
Dim StartRow As Long
Dim EndRow As Long
Dim row_number As Long
StartRow = Sheet6.Range("D5").Value
EndRow = Sheet6.Range("D5").Value
For row_number = StartRow To EndRow
DoEvents
Next row_number
End Sub
In your spin button macro, you can read the validation settings from the cell and decide whether to increment/decrement the number
Sub Tester()
Dim c As Range
Set c = Range("D4")
If Not c.Validation Is Nothing Then
If c.Validation.Type = xlValidateWholeNumber And _
c.Validation.Operator = xlBetween Then
Debug.Print "Min", c.Validation.Formula1
Debug.Print "Max", c.Validation.Formula2
End If
End If
End Sub
So my final solution ended up being a bit different than I was envisioning. Nixed the idea of a customized spin button using macros and images and went with the form control spin buttons. The full code uses information in a defined sheet that contains information and populates a generic message with personalized information and HTML formatting. My spin button was to help me pick what range of rows I wanted to include (since the function is using the .Display method rather than .Send as I wanted to personally check each email before it went out, and there were a lot of rows, this enabled me to more easily decide how many emails I wanted to display at one time). First the e-mail code (customized from an original work by Alex Cantu ):
Sub SendMyEmals(what_address As String, subject_line As String, mail_body_message As String)
Dim olApp As Outlook.Application
Dim oAttach As Outlook.Attachment
Set olApp = CreateObject("Outlook.Application")
Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.To = what_address
.Attachments.Add = "C:\",olByValue, 0
'your directory reference, I used this for my header image",
.Attachments.Add = "C:\",olByValue, 0
'other directory reference, used for footer image
.Subject = "Pick your subject"
.BodyFormat = olFormatHTML
.HTMLBody = "<img src='cid:"Your_image_name'"&"width = 'whatever' height = 'whatever' <br> <br>" mail_body_message & "&"img src='cid:Your_other_image'" &"width = 'whatever' height = 'whatever'>"
.Display
End With
End Sub
Sub MassEmail()
Dim mail_body_message As String
Dim A As String
Dim B As String
Dim C_name As String
Dim D As String
Dim RowStart As String
Dim RowEnd As String
Dim row_number As String
With Worksheets("Your_Worksheet")
RowStart = SheetX.Range("Your Range").Value
'this is the sheet where I stored the generic HTML message where I used replace text to be filled in by the row ranges from the main sheet "Your_Worksheet"
RowEnd = SheetX.Range("Your Other Range").Value
For row_number = RowStart To RowEnd
DoEvents
mail_body_message = SheetX.Range("Where the HTML was stored")
A = Sheet1.Range("A" & row_number)
B = Sheet1.Range("B" & row_number)
C = Sheet1.Range("C" & row_number)
D = Sheet1.Range("D" & row_number)
what_address = Sheet1.Range("D"& row_number)
'that is the column where I stored the individual email addresses
mail_body_message = Replace(mail_body_message, "replace_A_here", A)
mail_body_message = Replace(mail_body_message, "replace_B_here", B)
mail_body_message = Replace(mail_body_message, "replace_C_here", C)
mail_body_message = Replace(mail_body_message, "replace_D_here", D)
Call SendMyEmails(Sheet1.Range("D"&row_number), "This is a test email", mail_body_message
Next row_number
End With
End Sub
Anyway, it worked the way I was trying to get it to, I am sure there may have been more elegant ways to do it, but I am happy with this workaround for now.
I have a named range lstVendors that refers to: =OFFSET(Data!$W$2,0,0,COUNTA(Data!$W$2:$W$400),1). I want this range to be populated when the workbook opens. I have the following code for this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Range("lstVendors").Offset(0, 0).Value = "Please Select..."
' Set DropDown1 = ThisWorkbook.Sheets("Dashboard").DropDowns("Drop Down 1")
' DropDown1.Value = 1
On Error Resume Next
If Not IsError(Range("lstVendors")) Then
Range("lstVendors").ClearContents
End If
On Error GoTo 0
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
Set startRng = Range("lstVendors")
i = 0
For n = 2 To UBound(rslt)
Range("lstVendors").Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
It errors on the Set startRng = Range("lstVendors"). I know this is because there's nothing in the range when I'm trying to set it, because if I put one entry into the named range, the set works, however, I need it populated by the sqlite query on each open as the data changes.
Any suggestions much appreciated.
Try this. You have a dynamic range that doesn't evaluate after you clear the contents. To avoid this, there are probably several ways, but easy to simply hardcode the startRange variable so that it always points to Data!$W$2 address, which is (or rather, will become) the first cell in your lstVendors range.
Private Sub Workbook_Open()
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
Dim rngList As Range
'// Define your startRange -- always will be the first cell in your named range "lstVendors"
' hardcode the address because the dynamic range may not evalaute.
Set startRange = Sheets("Data").Range("W2")
'// Empty th lstVendors range if it exists/filled
On Error Resume Next
Range("lstVendors").Clear
On Error GoTo 0
'// Run your SQL query
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
i = 0
'// Print results to the Worksheet, beginning in the startRange cell
For n = 2 To UBound(rslt)
'Increment from the startRange cell
startRange.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
'Verify that "lstVendors" is being populated
Debug.Print Range("lstVendors").Address
Next n
End Sub
Thanks for the suggestions. Here is what I ended up doing in order to get around my problem. It involves adding something I didn't specify would be ok in my original question, so David's answer is great if what I did isn't an option. I first populated the first two cells in my named range with "Please Select..." and "All". In Sub Workbook_Open() we do this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
' Disable our not found message
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Set our start range to our named range
Set startRng = Range("lstVendors")
' Grab all vendor names
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
' Print result. Skip first two rows as constants "Please Select..." and "All" are populated there
i = 2
For n = 2 To UBound(rslt)
startRng.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
Then we will create Sub Workbook_BeforeClose:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Disable the save changes dialog. This workbook will be locked up for display only. No need to confuse the user.
Application.DisplayAlerts = False
' Clear everything below the "Please Select..." and "All" cells in the named range
On Error Resume Next
Range("lstVendors").Offset(2, 0).ClearContents
On Error GoTo 0
' Save the changes to the named range
ThisWorkbook.Save
Application.DisplayAlerts = True
End Sub
This information is going to populate a drop down, so having Please Select and All hardcoded into the named range is acceptable for me. If that stipulation doesn't work for someone else looking at this in the future, please use David's suggestion! Thanks again!