I am trying to Vlookup a cell to return a match in a contact list.
When it finds that match it should send an email to the person associated with that location.
Sub vLookupAnotherWorksheet()
Dim myLookupValue As String
Dim myFirstColumn As Long
Dim myLastColumn As Long
Dim myColumnIndex As Long
Dim myFirstRow As Long
Dim myLastRow As Long
Dim myVLookupResult As Long
Dim myTableArray As Range
myLookupValue = "H3:H13"
myFirstColumn = 1
myLastColumn = 8
myColumnIndex = 8
myFirstRow = 3
myLastRow = 13
With Worksheets("EVC_Contact_List")
Set myTableArray = .Range(.Cells(myFirstRow, myFirstColumn), .Cells(myLastRow, myLastColumn))
End With
On Error Resume Next
myVLookupResult = WorksheetFunction.VLookup(myLookupValue, myTableArray, myColumnIndex, False)
If IsError(myVLookupResult) = False Then
Call Send_Email(myvalue)
End If
End Sub
Sub Send_Email(myvalue As Variant)
Dim Email_Subject As String, Email_Send_From As String, Email_Body As String, i As Integer
Dim Mail_Object As Object, nameList As String, namelist2 As String, o As Variant
Email_Send_From = ""
If Sheets("EVC_Contact_List").Cells(2, 4).Value <> "" Then
nameList = Join(Application.WorksheetFunction.Transpose(Sheets("EVC_Contact_List").Range("D2:D29")))
namelist2 = Join(Application.WorksheetFunction.Transpose(Sheets("EVC_Contact_List").Range("F2:F29")))
End If
Set Mail_Object = CreateObject("Outlook.Application")
With Mail_Object.CreateItem(o)
.Subject = "Unit(s) Excceding Days as Loaner"
.To = nameList
.Cc = namelist2
.display
End With
Application.DisplayAlerts = False
End Sub
If location XXXX is found on the contact list and Johnsmith#gmail.com is associated with that location it should send an email only to John Smith.
My code is sending an email to everyone on the contact list.
You have this:
nameList = Join(Application.WorksheetFunction.Transpose(Sheets("EVC_Contact_List").Range("D2:D29")))
Should that not be the Vlookup function?
Related
My Excel raw data looks something like this:
;123456p,Roses and butterflies;;124456h,Violets are blue;
;123456d,Hello world;
Expected output:
Roses and butterflies
Violets are blue
Hello world
Trying to split the text sentences out only, for rows with multiple sentences I would need them in
separate rows, is this at all possible? Below is what I tried.
Private Sub CommandButton1_click()
Dim splitstring As String
Dim myarray() As String
splitstring = Worksheets("raw").Cells(1, 1).Value
myarray = Split(splitstring, ";")
For i = 0 To URound(myarray)
Next
End Sub
Sub raw()
End Sub
With Regular Expressions, you can populate Column B with the desired results ae below
Option Explicit
Private Sub CommandButton1_click()
Dim wSh As Worksheet
Dim rngStr As String, rngStrArr() As String, i As Long
Set wSh = Worksheets("raw")
Dim regEx As Object, mc As Object
Set regEx = CreateObject("vbscript.regexp")
regEx.Global = True
regEx.IgnoreCase = True
rngStr = Join(Application.Transpose(Application.Index(( _
wSh.Range("A1:A" & wSh.Cells(wSh.Rows.Count, 1).End(xlUp).Row)), 0, 1)))
regEx.Pattern = ",([^;]+);"
Set mc = regEx.Execute(rngStr)
rngStr = ""
For i = 0 To mc.Count - 1
rngStr = rngStr & mc(i)
Next i
rngStr = Replace(rngStr, ",", "")
rngStrArr = Split(rngStr, ";")
wSh.Range("B1").Resize(UBound(rngStrArr), 1).Value = Application.Transpose(rngStrArr)
End Sub
Try this:
Private sub SplitString()
Dim splitstring As String
Dim myarray() As String
splitstring = Cells(1, 1).Value
myarray = Split(splitstring, ",")
For i = 1 To UBound(myarray)
MsgBox (myarray(i))
Next
End Sub
Here is what I have been given to try and create:
User creates an email a few times per week and has to re-type everything, a request for employee updates, with up to 5 people on it. Easy enough to create in VBA, except that the employees could change each time. So there could be just 1 person, or 2, or 3, etc...and each time it could be a different mix of the employees. They want input boxes that would prompt how many employees for the email, then based on that input, follow-up boxes (if more than 1) that allow the input of the names (1 per box). It then needs to create the email, placing the input box data into the body text. Each email text will be based on the input from the 1st input box, so it can adjust for the number of employees (so there could be up to 5 employees on each email).
How do I assign values to my variables (findstrs and foundcells)so that they will adjust to the inputs of the inputboxes without writing all the IF stmts?
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim strbox As String
Dim stritem As String
Dim X As Long
Dim r As Long
Dim LR, lookrng As Range
Dim findStr As String
Dim nameCol As Range
Dim nameCol1 As Range
Dim nameCol2 As Range
Dim nameCol3 As Range
Dim nameCol4 As Range
Dim foundCell As Variant
Dim foundCell1 As Variant
Dim foundcell2 As Variant
Dim strname As String
Dim strBody As String
Dim sigString As String
Dim signature As String
Dim findstr1 As String
Dim foundrng As Range
Dim valuefound As Boolean
Dim strFilename As String
Select Case Application.ActiveWindow.Class
Case olInspector
Set oMail = ActiveInspector.CurrentItem
Case olExplorer
Set oMail = ActiveExplorer.Selection.Item(1)
End Select
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Set oReply = oMail.ReplyAll
Select Case Application.ActiveWindow.Class
Case olInspector
Set oMail = ActiveInspector.CurrentItem
Case olExplorer
Set oMail = ActiveExplorer.Selection.Item(1)
End Select
Set aOutlook = CreateObject("Outlook.Application")
Set oReply = aOutlook.CreateItem(0)
'Input box(es)
findStr = InputBox("Enter Number of Employees")
findstr1 = InputBox("Enter Name of First Employee")
If findStr = "2" Then findstr2 = InputBox("Enter Name of Second Employee")
If findstr1 = "T1" Then foundCell1 = "<B>Test 1 ID#0000</B>"
If findstr1 = "T2" Then foundcell2 = "<B>Test 2 IDO#0001</B>"
If findstr1 = "T3" Then foundcell3 = "<B>Test 3 ID#0002</B>"
If findstr1 = "T4" Then foundCell4 = "<B>Test 4 ID#0003</B>"
If findstr1 = "T5" Then foundCell5 = "<B>Test 5 ID#0004</B>"
If findstr2 = "T1" Then foundCell1 = "<B>Test 1 ID#0000</B>"
If findstr2 = "T2" Then foundcell2 = "<B>Test 2 IDO#0001</B>"
If findstr2 = "T3" Then foundcell3 = "<B>Test 3 ID#0002</B>"
If findstr2 = "T4" Then foundCell4 = "<B>Test 4 ID#0003</B>"
If findstr2 = "T5" Then foundCell5 = "<B>Test 5 ID#0004</B>"
'Greeting based on time of day
Select Case Time
Case 0.25 To 0.5
GreetTime = "Good morning"
Case 0.5 To 0.71
GreetTime = "Good afternoon"
Case Else
GreetTime = "Good evening"
End Select
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Update.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
If findStr = "1" Then
strBody = "<Font Face=calibri>Can you please update the following: <br><br>" & _
"<B>" & foundCell1 & "</B><br><br>" & _
"Please update this batch. " & _
"I Appreciate your help. Let me know if you need anything.<br><br>" & _
"Thanks <br><br>" & _
subject = "Employee Update"
ElseIf findStr = "2" Then
strBody = "<Font Face=calibri>Can you please add changes for the following: " & _
"<ol><li><B>" & foundCell1 & "</B><br><br><br><br>" & _
"<li><B>" & foundcell2 & "</B><br><br>" & _
subject = "Multiple Employee Requests"
End If
'Sets up the email itself and then displays for review before sending
With oReply
.HTMLBody = "<Font Face=calibri>Hi there,<br><br>" & strBody & signature
.To = "superman#krypton.com"
.CC = "trobbins#shawshank.com "
.subject = "Multiple Employee Updates"
.Importance = 2
.Display
End With
End Sub
You need to break this code down into multiple, smaller and parameterized scopes.
Make a Function that returns the body of the email given a Collection of batch numbers.
Private Function GetEmailBody(ByVal batchNumbers As Collection) As String
Now, the calling code needs to know how many employees there are. Make a function for that.
Private Function GetNumberOfEmployees() As Long
Dim rawInput As Variant
rawInput = InputBox("Number of employees?")
If StrPtr(rawInput) = 0 Then
'user cancelled out of the prompt
GetNumberOfEmployees = -1
Exit Function
Else If IsNumeric(rawInput) Then
GetNumberOfEmployees = CLng(rawInput)
End If
End Function
That'll return -1 if user cancels the prompt, 0 for an invalid input, and the number of employees otherwise.
Dim employeeName As String
Dim nbEmployees As Long
nbEmployees = GetNumberOfEmployees
If nbEmployees = -1 Then
Exit Sub 'bail out
Else If nbEmployees = 0 Then
'reprompt?
Exit Sub 'bail out, cancelled
End If
'fun part here
Dim emailbody As String
emailBody = GetEmailBody(batchNumbers, employeeName)
And now the fun part: you need to add as many items to some batchNumbers collection, as you have nbEmployees. Because you know how many iterations you'll need before you start looping, a For loop will do.
Dim batchNumbers As Collection
Set batchNumbers = New Collection
Dim batchNumber As String
Dim i As Long
For i = 1 To nbEmployees
batchNumber = GetBatchNumber(i)
If batchNumber = vbNullString Then Exit Sub 'bail out:cancelled/invalid
batchNumbers.Add batchNumber
Next
Dim body As String
body = GetEmailBody(batchNumbers)
Where GetBatchNumber(i) is yet another function call, to a function whose role it is to prompt for an employee number and lookup & return the corresponding batch number, returning an empty string if prompt is cancelled or no match is found.
Private Function GetBatchNumber(ByVal index As Long) As String
Dim rawInput As Variant
rawInput = InputBox("Name of employe " & index & ":")
If StrPtr(rawInput) = 0 Then
'cancelled
Exit Function
Else
Dim employeeName as String
employeeName = CStr(rawInput)
GetBatchNumber = GetBatchForEmployee(employeeName)
End If
End Function
If the mappings really actually look like T1 -> <B>Test 1 ID#000</B> then you can probably use this:
Private Function GetBatchForEmployee(ByVal employeeName As String)
Dim digit As Long
digit = CLng(Right$(employeeName, 1))
GetBatchForEmployee = "<B>Test " & digit & " ID#" & Format$(digit - 1, "000") & "</B>"
End Function
If your mappings are actual mappings then you can have a Dictionary lookup in here, or look them up on an Excel worksheet, a CSV or XML data file, a SQL Server database, whatever.
But first, break things down. A procedure that starts like this:
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim strbox As String
Dim stritem As String
Dim X As Long
Dim r As Long
Dim LR, lookrng As Range
Dim findStr As String
Dim nameCol As Range
Dim nameCol1 As Range
Dim nameCol2 As Range
Dim nameCol3 As Range
Dim nameCol4 As Range
Dim foundCell As Variant
Dim foundCell1 As Variant
Dim foundcell2 As Variant
Dim strname As String
Dim strBody As String
Dim sigString As String
Dim signature As String
Dim findstr1 As String
Dim foundrng As Range
Dim valuefound As Boolean
Dim strFilename As String
...is a procedure that's doing way too many things.
I have a Excel VBA (Send_Mail) to send emails thru Lotus Notes. It is working fine, however I need help in sending individual email to multiple people in one go.
In my excel sheet. Cell A7 downwards will be the email addresses that can go upto 200+ rows, B7 has the subject Line and Cell C7 has the body of email. (all of this is getting auto populated with a different macro). However my code (Send_Mail) is just sending one email to the address which is in cell A7. I need your help in sending mail to all the email address that are in Col A7 onwards with its respective subject (Col B) and mail body (col C)
Below is my code.
Public TOID As String
Public CCID As String
Public SECT As String
Public ACCO As String
Public SUBJ As String
Sub Send_Mail()
Dim answer As Integer
answer = MsgBox("DO YOU HAVE LOTUS NOTES OPEN ?? Not WebLotus notes", vbYesNo + vbQuestion, "LOTUS NOTES")
If answer = vbNo Then
MsgBox "Please Open Notes and Try the Macro Again"
Exit Sub
Else
End If
Application.DisplayAlerts = False
Call Send
MsgBox "Mail Sent to " & (Range("L2").Value) & " " & "Recipents"
Application.DisplayAlerts = True
End Sub
Public Function Send()
SendEMail = True
Sheets("Main").Select
TOID = Range("A7").Value
CCID = ""
SUBJ = Range("B7").Value
'On Error GoTo ErrorMsg
Dim EmailList As Variant
Dim ws, uidoc, Session, db, uidb, NotesAttach, NotesDoc, objShell As Object
Dim RichTextBody, RichTextAttachment As Object
Dim server, mailfile, user, usersig As String
Dim SubjectTxt, MsgTxt As String
Set Session = CreateObject("Notes.NotesSession")
user = Session.UserName
usersig = Session.COMMONUSERNAME
mailfile = Session.GETENVIRONMENTSTRING("MailFile", True)
server = Session.GETENVIRONMENTSTRING("MailServer", True)
Set db = Session.GETDATABASE(server, mailfile)
If Not db.IsOpen Then
Call db.Open("", "")
Exit Function
End If
Set NotesDoc = db.CREATEDOCUMENT
With NotesDoc
.Form = "Memo"
.Subject = SUBJ 'The subject line in the email
.Principal = user
.sendto = TOID 'e-mail ID variable to identify whom email need to be sent
.CopyTo = CCID
End With
Set RichTextBody = NotesDoc.CREATERICHTEXTITEM("Body")
With NotesDoc
.COMPUTEWITHFORM False, False
End With
'==Now set the front end stuff
Set ws = CreateObject("Notes.NotesUIWorkspace")
If Not ws Is Nothing Then
Set uidoc = ws.EDITDOCUMENT(True, NotesDoc)
If Not uidoc Is Nothing Then
If uidoc.EDITMODE Then
'Mail Body
Sheets("Main").Select
Range("C7").Select
Dim rnBody1 As Range
Set rnBody1 = Selection
rnBody1.CopyPicture
'rnBody1.Copy
Call uidoc.GOTOFIELD("Body")
Call uidoc.Paste
End If
End If
End If
Call uidoc.Send
Call uidoc.Close
'close connection to free memory
Set Session = Nothing
Set db = Nothing
Set NotesAttach = Nothing
Set NotesDoc = Nothing
Set uidoc = Nothing
Set ws = Nothing
Sheets("Main").Select
End Function
I am worried about confusing you with too much new detail and must profess i haven't tested the following code so please don't assume this will solve your problem outright.
The following gives you an idea of how you might use a loop as you requested. See example also here which covers instances where you might need to batch send (admittedly link is for Outlook) and is also an example of using a loop.
I have included some explanations along the way in the code. It is difficult without more information to properly tailor this but i hope it helps.
Option Explicit
Public TOID As String
Public CCID As String
Public SECT As String
Public ACCO As String
Public SUBJ As String
Public Sub Send_Mail()
Dim wb As Workbook
Dim ws1 As Worksheet
Set wb = ThisWorkbook 'These are assumptions
Set ws1 = wb.Worksheets("Sheet1") 'These are assumptions. You would change as necessary
Dim answer As Long 'Integer types changed to Long
answer = MsgBox("DO YOU HAVE LOTUS NOTES OPEN ?? Not WebLotus notes", vbYesNo + vbQuestion, "LOTUS NOTES")
If answer = vbNo Then
MsgBox "Please Open Notes and Try the Macro Again"
Exit Sub
'Else 'Not being used so consider removing
End If
Application.DisplayAlerts = False
Dim lRow As Long
Dim loopRange As Range
Dim currentRow As Long
Dim TOIDvar As String
Dim SUBJvar As String
With ws1
lRow = .Range("A7").End(xlDown).Row 'Assume no gaps in column A in the TOID range
Set loopRange = .Range("A7:A" & lRow)
For currentRow = 1 To loopRange.Rows.Count 'Loop range assigning values to arguments and call send sub with args
TOIDvar = loopRange.Cells(currentRow, 1)
SUBJvar = loopRange.Cells(currentRow, 1).Offset(0, 1) ' get column B in same row using Offset
Send TOIDvar, SUBJvar
Next currentRow
End With
'Commented out MsgBox at present as unsure what you will do when sending multiple e-mails
'MsgBox "Mail Sent to " & (ws1.Range("L2").Value) & " " & "Recipents" 'use explicit fully qualified Range references
Application.DisplayAlerts = True
End Sub
Public Sub Send(ByVal TOIDvar As String, ByVal SUBJvar As String) 'changed to sub using arguments
Dim SendEMail As Boolean 'declare with type
Dim wb As Workbook
Dim ws2 As Worksheet
Set wb = ThisWorkbook 'These are assumptions. Ensuring you are working with correct workbook
Set ws2 = wb.Worksheets("Main")
SendEMail = True
TOID = TOIDvar
CCID = vbNullString 'use VBNullString rather than empty string literals
SUBJ = SUBJvar
'On Error GoTo ErrorMsg
Dim EmailList As Variant 'declaration of separate lines and with their types
Dim ws As Object
Dim uidoc As Object
Dim Session As Object
Dim db As Object
Dim uidb As Object
Dim NotesAttach As Object
Dim NotesDoc As Object
Dim objShell As Object
Dim RichTextBody As Object
Dim RichTextAttachment As Object
Dim server As String
Dim mailfile As String
Dim user As String
Dim usersig As String
Dim SubjectTxt As String
Dim MsgTxt As String
Set Session = CreateObject("Notes.NotesSession")
user = Session.UserName
usersig = Session.COMMONUSERNAME
mailfile = Session.GETENVIRONMENTSTRING("MailFile", True)
server = Session.GETENVIRONMENTSTRING("MailServer", True)
Set db = Session.GETDATABASE(server, mailfile)
If Not db.IsOpen Then
db.Open vbNullString, vbNullString
Exit Sub
End If
Set NotesDoc = db.CREATEDOCUMENT
With NotesDoc
.Form = "Memo"
.Subject = SUBJ 'The subject line in the email
.Principal = user
.sendto = TOID 'e-mail ID variable to identify whom email need to be sent
.CopyTo = CCID
End With
Set RichTextBody = NotesDoc.CREATERICHTEXTITEM("Body")
With NotesDoc
.COMPUTEWITHFORM False, False
End With
'==Now set the front end stuff
Set ws = CreateObject("Notes.NotesUIWorkspace")
If Not ws Is Nothing Then
Set uidoc = ws.EDITDOCUMENT(True, NotesDoc)
If Not uidoc Is Nothing Then
If uidoc.EDITMODE Then
'Mail Body
With ws2.Range("C7")
Dim rnBody1 As Range
Set rnBody1 = .Value2
rnBody1.CopyPicture
'rnBody1.Copy
uidoc.GOTOFIELD "Body"
uidoc.Paste
End With
End If
End If
End If
uidoc.Send
uidoc.Close
'removed garbage collection
ws2.Activate ' swopped out .Select and used Worksheets collection held in variable ws2
End Sub
You may want to consider this.
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
See this link for all details.
https://www.rondebruin.nl/win/s1/outlook/amail6.htm
We have a team email address that we CC for most correspondence, and then we all get a copy of all emails.
The problem is when we then reply all, and a team member has already been in the email chain that person will get the email 2 times.
This is what I tried.
Private Sub RemoveRecipientsWhenItemSend(Item As Outlook.MailItem)
Dim RemoveAddrList As VBA.Collection
Dim InfoAddrList As VBA.Collection
Dim Recipients As Outlook.Recipients
Dim aRecipient As Outlook.Recipient
Dim bRecipient As Outlook.Recipient
Dim i
Dim j
Dim a
Dim b
Dim info As Boolean
info = False
Set RemoveAddrList = New VBA.Collection
Set InfoAddrList = New VBA.Collection
InfoAddrList.Add "team#company.com"
RemoveAddrList.Add "member1#company.com"
RemoveAddrList.Add "member2#company.com"
Set Recipients = Item.Recipients
For i = Recipients.Count To 1 Step -1
Set aRecipient = Recipients.Item(i)
For j = 1 To InfoAddrList.Count
If LCase$(aRecipient.Address) = LCase$(InfoAddrList(j)) Then
For a = Recipients.Count To 1 Step -1
Set bRecipient = Recipients.Item(a)
For b = 1 To RemoveAddrList.Count
If LCase$(aRecipient.Address) = LCase$(RemoveAddrList(b)) Then
Recipients.Remove i
Exit For
End If
Next
Next
Exit For
End If
Next
Next
End Sub
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
On Error Resume Next
RemoveRecipientsWhenItemSend Item
End Sub
A few Debug.Print statements proved helpful.
Option Explicit
Private Sub RemoveRecipientsWhenItemSend(Item As Outlook.mailitem)
Dim RemoveAddrList As VBA.Collection
Dim InfoAddrList As VBA.Collection
Dim Recipients As Outlook.Recipients
Dim aRecipient As Outlook.Recipient
Dim bRecipient As Outlook.Recipient
Dim i
Dim j
Dim a
Dim b
Dim info As Boolean
info = False
Set RemoveAddrList = New VBA.Collection
Set InfoAddrList = New VBA.Collection
InfoAddrList.Add "team#company.com"
RemoveAddrList.Add "member1#company.com"
RemoveAddrList.Add "member2#company.com"
Set Recipients = Item.Recipients
For i = Recipients.count To 1 Step -1
Set aRecipient = Recipients.Item(i)
For j = 1 To InfoAddrList.count
Debug.Print LCase$(aRecipient.Address)
Debug.Print LCase$(InfoAddrList(j))
If LCase$(aRecipient.Address) = LCase$(InfoAddrList(j)) Then
For a = Recipients.count To 1 Step -1
'Set bRecipient = Recipients.Item(a)
Set aRecipient = Recipients.Item(a)
For b = 1 To RemoveAddrList.count
Debug.Print vbCr & " a: " & a
Debug.Print " LCase$(aRecipient.Address): " & LCase$(aRecipient.Address)
Debug.Print " LCase$(RemoveAddrList(b)): " & LCase$(RemoveAddrList(b))
If LCase$(aRecipient.Address) = LCase$(RemoveAddrList(b)) Then
'Recipients.Remove i
Recipients.Remove a
Exit For
End If
Next
Next
Exit For
End If
Next
Next
End Sub
Private Sub RemoveRecipientsWhenItemSend_test()
RemoveRecipientsWhenItemSend ActiveInspector.currentItem
End Sub
Here is something I use to remove the duplicate recipients.
Set olemail = olapp.CreateItemFromTemplate(OutlookTemplate)
With olemail
' other stuff
' check duplicate recipients
' first resolve email address per global address book
For Each Recipient In .Recipients
Recipient.Resolve
Next
' go through each recipients and check for dup
If .Recipients.count > 1 Then
For i = .Recipients.count To 2 Step -1
For j = i - 1 To 1 Step -1
If .Recipients(i) = .Recipients(j) Then
.Recipients.Remove (i)
i = i - 1
End If
Next j
Next i
End If
end with
Excel 2010 VBA: I'm trying to loop through files in a folder and only open the files with names that contain a certain string. I've done this before and I know the logic works, but I keep getting the 424 error when I'm opening the target files. I'm pretty sure it has something to do with the links and have tried EVERYTHING to turn off those alerts problematically, but I'm still getting the error
Private Sub CommandButton1_Click()
Dim lSecurity As Long
Dim myPath As Variant
lSecurity = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityLow
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
myPath = "F:\Pathname"
Call Recurse(myPath)
Application.AutomationSecurity = lSecurity
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
End Sub
Function Recurse(sPath As Variant) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myFile As Variant
Dim file As String
Dim A As Workbook
Dim B As Workbook
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim count As Integer
Set myFolder = FSO.GetFolder(sPath)
Set A = ThisWorkbook
i = 2
For Each myFile In myFolder.Files
If InStr(myFile.Name, "_2015_DOMESTIC_TB") <> 0 Then
Set B = Workbooks.Open(Filename:=myFile)
Call Datadump
B.Close SaveChanges:=False
End If
i = i + 1
Next
End Function
Function Datadump()
A.Cells(i, 1).Value = B.Cells(1, 4).Value
For count = 1 To 59
k = 2
A.Cells(i, k).Value = B.Cells(11 + count, 4).Value
count = count + 1
k = k + 1
Next count
End Function
Seems like your function is trying to open a non Excel file. Change your function to (Untested as posting from phone)
Function Recurse(sPath As Variant) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myFile As Variant
Dim file As String
Dim A As Workbook, B As Workbook
Dim i As Integer, j As Integer, k As Integer, count As Integer
Dim MyAr As Variant
Set myFolder = FSO.GetFolder(sPath)
Set A = ThisWorkbook
i = 2
For Each myFile In myFolder.Files
If InStr(myFile.Name, "_2015_DOMESTIC_TB") <> 0 Then
MyAr = Split(myFile.Name, ".")
If MyAr(UBound(MyAr)) Like "xls*" Then '<~~ Check if it is an Excel file
Set B = Workbooks.Open(Filename:=myFile.Name)
Call Datadump
B.Close SaveChanges:=False
End If
End If
i = i + 1
Next
End Function
This function will check that you are trying to open a valid excel file.
If you still get the error then please tell us which line is giving you the error and what is the value of myFile.Name at the time of error.