I am new to VBA. I am working hard and learning it but there is a point where I am stuck now. If someone please help me out then I shall be grateful.
I have a drop down list in excel like
Sales/Acquisition Manager (AM) Alina (Alina#yahoo.com)
Acquisition Project Manager (APM) Benny(Benny#yahoo.com)
Manufacturing Julia(Julia#yahoo.com)
Application please select (drop down list so I can choose)
AE external sensor responsible please select (Drop down list so I can choose)
I have made a separate row (row 59 Col A) where I have combined these values from the above rows.
I have to make a macro to send 1 email to these multiple people. I have written a code for sending email but I am stuck at another point. I have written code which replaces the words please select with “ ” whenever it finds it in row 59 but unfortunately that code changes the line permanently which I don’t want.
What I want is that whenever it finds the words please select in a row it just ignores it and and also doesn't change the format of cell. Means when I again change some new value by drop down list so it got changed.
Private Sub CommandButton1_Click()
Dim the_string As String
the_string = Sheets("Schedule_team").Range("A59")
the_string = Replace(the_string, "please select", " ")
Sheets("Schedule_team").Range("A59") = the_string
MsgBox (Sheets("Schedule_team").Range("A59"))
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long, x As Variant
Set Mail_Object = CreateObject("Outlook.Application")
x = Cells (59, 1).Value
With Mail_Object.CreateItem(o)
' .Subject = Range("B1").Value
.To = x
' .Body = Range("B2").Value
' .Send
.display 'disable display and enable send to send automatically
End With
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub
Pull the contents of A59 into the string, replace as needed, then just use that string instead of copying it back to the sheet.
Untested, just used your code
Private Sub CommandButton1_Click()
Dim Mail_Object as Object
Dim the_string As String
the_string = Sheets("Schedule_team").Range("A59")
the_string = Replace(the_string, "please select", " ")
Set Mail_Object = CreateObject("Outlook.Application")
With Mail_Object.CreateItem(o)
' .Subject = Range("B1")
.To = the_string
' .Body = Range("B2")
' .Send
.Display 'disable display and enable send to send automatically
End With
MsgBox "E-mail successfully sent", 64
End Sub
Related
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
Hallo all i am trying to figure out the issue i have tried but not got successful. Can anyone please help me out in this . I shall be grateful to you.
Task:
I have a drop down list in excel like
Sales/Acquisition Manager (AM)-------------------------------Alina (Alina#yahoo.com)
Acquisition Project Manager (APM)--------------------------Benny(Benny#yahoo.com)
Manufacturing ----------------------------------------------------Julia(Julia#yahoo.com)
Application ---------------------------------------------------------please select (drop down list so I can choose)
AE external sensor responsible-------------------------------please select (Drop down list so I can choose)
I have made a separate row (row 59 Col A) where I have combined these values from the above rows.
I have to make a macro to send 1 email to these multiple people. I have written a code for sending email but I am stuck at some point. I have written a code which replaces the word please
select with “ ” whenever it finds in row 59 but unfortunately that code changes the line permanently which I don’t want.
What I want is that whenever it finds a word please select in a row it just ignores it and and also don’t change the format of cell. Means when I again change some new value by drop down list so it got changed. I shall be really grateful to you if you please help me out in this . Thanks a lot.please check the attached pics also.enter image description hereenter image description here
Private Sub CommandButton1_Click()
Dim the_string As String
the_string = Sheets("Schedule_team").Range("A59")
the_string = Replace(the_string, "please select", " ")
Sheets("Schedule_team").Range("A59") = the_string
MsgBox (Sheets("Schedule_team").Range("A59"))
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long, x As
Variant
Set Mail_Object = CreateObject("Outlook.Application")
x = Cells (59, 1).Value
With Mail_Object.CreateItem(o)
' .Subject = Range("B1").Value
.To = x
' .Body = Range("B2").Value
' .Send
.display 'disable display and enable send to send automatically
End With
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub
You don't put quotes around the_string inside the Replace()
the_string = Replace("the_string", "please select", " ")
should be:
the_string = Replace(the_string, "please select", " ")
Here's a slight refactoring of your code which removes the need for that variable:
Sub RemoveHypens()
With Sheets("Home").Range("A59")
.Value = Replace(.Value, "please select", " ")
End with
End Sub
EDIT: based on your updated question -
Private Sub CommandButton1_Click()
Dim the_string As String
Dim i As Integer, Mail_Object, Email_Subject, o As Variant
Dim lr As Long
the_string = Sheets("Schedule_team").Range("A59").Value
the_string = Replace(the_string, "please select", " ")
Set Mail_Object = CreateObject("Outlook.Application")
With Mail_Object.CreateItem(o)
'.Subject = Range("B1").Value
.To = the_string
'.Body = Range("B2").Value
'.Send
.display 'disable display and enable send to send automatically
End With
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
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 worksheet that tracks invoices and I am trying to generate an auto-emailer that if a cell in column 12 contains AUTOEMAIL it will combine all of the rows with a similar email address which I've generated using a TRIM function. It will pull all of the like rows (Email Addresses based on column 15) into a LotusNotes Email. Ron De Bruin has some fantastic examples on his site. I attempted to write a loop which attempts to loop through and copy all rows based on an email address. When I go to run, the code does nothing but no errors are presented. There are instances online of this done in Outlook, but they don't apply to LotusNotes as the issue is late vs early binding. I'm newer to VBA automation as well.
Sub Send_Data()
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim vaRecipient As Variant
Dim rnBody As Range
Dim Data As DataObject
Const stSubject As String = "TEST"
Const stMsg As String = "TEST"
Const stPrompt As String = "Please select the range:"
lastrow = Range("N" & Rows.Count).End(xlUp).row
For Each Cell In Range("N8:N" & lastrow)
If WorksheetFunction.CountIf(Range("N8:N" & Cell.row), Cell) = 1 Then
If Cells(Cell.row, 11) = "AUTOEMAIL" Then
rnBody = "Hello" & vbNewLine & vbNewLine & _
ActiveCell.EntireRow.Select
On Error Resume Next
'The user canceled the operation.
If rnBody Is Nothing Then Exit Sub
On Error GoTo 0
'Instantiate Lotus Notes COM's objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'Make sure Lotus Notes is open and available.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the document for the e-mail.
Set noDocument = noDatabase.CreateDocument
'Copy the selected range into memory.
rnBody.Copy
'Retrieve the data from then copied range.
Set Data = New DataObject
Data.GetFromClipboard
'Add data to the mainproperties of the e-mail's document.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.Subject = stSubject
'Retrieve the data from the clipboard.
.Body = stMsg & " " & Data.GetText
.SaveMessageOnSend = True
End With
' SEND EMAIL
With noDocument
.PostedDate = Now()
.Send 0, vaRecipient
End With
' REMOVE FROM MEMORY
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'SWITCH BACK TO EXCEL
AppActivate "Microsoft Excel"
'EMPTY COPY-PAST CLIPBOARD
Application.CutCopyMode = False
' DISPLAYS TO USER IF SUCCESSFUL
MsgBox "Complete!", vbInformation
End If
End If
Next Cell
End Sub
I set the email body range as a Prompt Box where the user could highlight the cells and then another prompt box in which it asked for the email that was created using a TRIM() function. I realized that the way the code was set-up would not allow for what I wanted to do. The new method works quite well
Treevar
I have form on my website which gets emailed when the customer completes it, then looks like this:-
You got mail from Mr Kelley McIntyre.
Here is the form data:
First Name : Mr XXXXX
Last Name : XXXXXX
Company Name : Army
Email Address : XXXX#hotmail.co.uk
Telephone/Mobile No : 0123456789
Date of Event : 14/12/2013
Number of Guests : 80
Budget : 6500-7000
Type of Event : Other
Catering Required : Yes
Drinks and Entertainment Requirements : christmas meal, welcome drink, wine at table
British Army Warrant Officers & Sergeants plus wives and partners
How Did You Hear About Us? : Google
As you can see its fairly simple form, however I need to export this data into Excel every time I get one of these emails, so I can keep a record of all the enquiries we get.
Can someone help?
I know how to do a Macro, but if its VBA, then I'm lost, so its needs to be in idiot format if possible!
You can start with writing a macro to process an mail item. And setup Outlook Rule to pickup this type of email from Subject/Account then run the macro. Change sExcelFile, sRecordSheet, iC as you see fit. I have made assumptions.
This Code below is for Outlook, please note you need a running Outlook all the time to have this automation. It should get you started half way. Note you need "Microsoft Excel x.0 Object Library" in your References.
Public Sub Rules_WebSiteFormRecord(oMail As MailItem)
Const sExcelFile As String = "C:\Test\Record.xlsx"
Const sRecordSheet As String = "Record" ' Worksheet name
Dim oExcel As Excel.Application, oWB As Excel.Workbook, oWS As Excel.worksheet
Dim arrTxt As Variant, oLine As Variant, iR As Long, iC As Long, bWrite As Boolean
Set oExcel = CreateObject("excel.application")
Set oWB = oExcel.Workbooks.Open(FileName:=sExcelFile)
Set oWS = oWB.Worksheets(sRecordSheet)
' Make Excel visible for Debug purpose:
oExcel.Visible = True
' Find next row of Last used row in Excel worksheet
iR = oWS.Cells(Rows.Count, 1).End(xlUp).Row + 1
' Process email body and store it into columns of worksheet "sRecordSheet"
'Debug.Print oMail.Body
' Store received time of email in Column A
oWS.Cells(iR, 1).Value = oMail.ReceivedTime
' Split the email body into lines then process each
arrTxt = Split(oMail.Body, vbCrLf)
For Each oLine In arrTxt
bWrite = False
' store data according to text in line
If InStr(1, oLine, "First Name", vbTextCompare) Then
iC = 2 ' Column of First Name
bWrite = True
ElseIf InStr(1, oLine, "Last Name", vbTextCompare) Then
iC = 3 ' Column of First Name
bWrite = True
' Add the rest of the fields...
End If
If bWrite Then
oWS.Cells(iR, iC).Value = Split(oLine, ":")(1)
iR = iR + 1
End If
Next
Set oWS = Nothing
' Close the workbook with saving changes
oWB.Close True
Set oWB = Nothing
Set oExcel = Nothing
' mark it as Read if no error occurred
If Err.Number = 0 Then
oMail.UnRead = False
Else
MsgBox "ERR(" & Err.Number & ":" & Err.Description & ") while processing " & oMail.Subject
Err.Clear
End If
End Sub