How can make Sheet to activate in VBA from a variable? (A cell particularly) - vba

I am actually quite new to VBA but I am doing some coding to streamline my office work. I understand this would be some amateur level questions to most of you but I tried to google for quite a while and I do not find satisfactory answer.
I have an excel write up that based on the inputted parameters, It should ultimately refer to the correct sheet -> copy the selected cells -> Generate an e-Mail with the body pasting the copied cells along with an attachment
I can do most of the parts, just that I cannot reference the "Correct Sheet" as a variable in my codes. Please shed some lights on for me. Thank you.
Here are most of the codes, the rest are irrelevant and too clumsy to paste all I guess.
Sub GenerateEmail()
Dim olApp As Object
Dim olMailItm As Object
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Dim StrAtt1 As String
Dim rng As Range
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("test").Range("A1:Q500").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set olMailItm = olApp.CreateItem(0)
On Error Resume Next
With olMailItm
SDest = ""
StrAtt1 = ThisWorkbook.Path & "\PDF\" & Sheets("Email_Generator").Range("B16")
.To = Worksheets("Email_Generator").Range("B14")
.CC = "Myself"
.BCC = ""
.Subject = Worksheets("Email_Generator").Range("B18")
.HTMLBody = RangetoHTML(rng)
.attachments.Add StrAtt1
.Display
End With
Set olMailItm = Nothing
Set olApp = Nothing
End Sub
Specifically, I would like this code "Sheets("test") as a Cell in Sheet "Test" that is a variable based on the paramters I have inputted in my excel so that this code will reference to the correct worksheet
Set rng = Sheets("test").Range("A1:Q500").SpecialCells(xlCellTypeVisible)
But when I identify the sheet as a named sheet e.g. Sheets("Email1"), it perfectly works, just that it cannot become a variable.
I hope this post is not too long to read because I tried to be as specific as possible. Thank you to all who reads this and tries to help. I really appreciate it.

This function to return the worksheet name selected by the user from an InputBox. If the user cancels or enters an invalid number then the function returns a zero length string.
Sub TestFunction()
Dim SheetName As String
Dim rng As Range
SheetName = getSheetNameFromInputBox
If Len(SheetName) = 0 Then
MsgBox Prompt:="Try Again", Title:="Invalid Sheet"
Exit Sub
End If
Set rng = Sheets(SheetName).Range("A1:Q500").SpecialCells(xlCellTypeVisible)
MsgBox rng.Address(External:=True)
End Sub
Function getSheetNameFromInputBox() As String
Dim ws As Worksheet
Dim Prompt As String
Dim result
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Sheet3" Then
Prompt = Prompt & ws.Index & ") " & ws.Name & vbCrLf
End If
Next
result = InputBox(Prompt:=Prompt, Title:="Enter the Worksheet number", Default:=1)
On Error Resume Next
If IsNumeric(result) Then getSheetNameFromInputBox = Worksheets(CInt(result)).Name
On Error GoTo 0
End Function

Related

Excel Add-In/Macro to send mass email

So I have a task to automate. We have a protected spreadsheet (users only have 'read' access to) that get's updated by admins from time to time in order to add/remove users from a paid subscription mailing list. I'm trying to make the process of sending these emails out simpler to speed up the process and eliminate the potential of human error getting involved.
So email addresses are listed under the 'C' column, lists can be as long as in the tens of thousands, or it may only be 1 or 2. The workbook has several sheets that specify the data set that the subscribers subscribe to. So I put something together that worked
'This function will grab the information the macro asks for
Function RangeToString(ByVal myRange As Range) As String
RangeToString = ""
If Not myRange Is Nothing Then
Dim myCell As Range
For Each myCell In myRange
RangeToString = RangeToString & "; " & myCell.Value
Next myCell
'Remove extra comma
RangeToString = Right(RangeToString, Len(RangeToString) - 1)
End If
End Function
Sub EmailTest1()
Dim OutApp As Object
Dim OutMail As Object
Dim strSubject As String
Dim myString As String
Dim rng As Range
Dim strCopy As String
'Sheet1 would be Sheet2/3/4/etc. depending on what list we're pulling from.
Set rng = Sheet1.Range("c2:c90000")
myString = RangeToString(rng)
strCopy = "internal.private#email.com; internal1.private#email.co;
internal2.private#email.co"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate("\\Domain\EmailTemplate\oft\test1.oft")
On Error Resume Next
With OutMail
.BCC = myString + strCopy
.Display
'.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Then I had repeats of the second part that specify the different lists/email templates as individual macros within the Add-In. (.Send will not be commented out when I do finally get the results I want).
So this works perfectly, when the macro specifies and embeds a workbook into itself. So for a while, I thought that it was pulling everything fine, until I used a blank workbook, and it still pulled the data I wanted, so I checked and double checked that there was no reference to the original workbook, and then I discovered that the workbook was built into the macro. I tried rebuilding the add-in using the same code, and it just doesn't work.
So my question is, is there a way to build this macro so that it'll work on any active workbook? I imagine there has got to be a simple thing to click on or something else I'm overlooking. I'm working with Excel 2016.
first of all, why didn't you just make a macro-embedded template where you have a form that connects any active workbook.
dim ws as workbook
set ws=activeworkbook
so basically make a form that is modular then on a label click event put that code.
then an execute button so that you can determine if you connect the right workbook before you start the email sending automation
I think you can adapt this to suit your needs.
Make a list in Sheets("Sheet1") with :
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
https://www.rondebruin.nl/win/s1/outlook/amail6.htm

Need help in loop function in vba to send multiple emails

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

Copy row based on content and paste it in different sheets which are selected based on the content of the row

We've created a order sheet for all our machines, the main sheet is 'Order Sheet'.
And we're sending this sheet to the purchasing department at the end of the day.
When we run the macro to email the file, we wanted the macro to also copy each row to the specific machine worksheet. Eg. rows marked as 'Slicer' to go to the 'Slicer' sheet, 'blender' to 'blender', etc.
This is what I've got so far:
Sub PrintToNetwork()
ActiveWorkbook.Save
Range("A2:N25").Font.Size = 11
Dim OutApp As Object
Dim OutMail As Object
Dim answer As Integer
answer = MsgBox("Are you sure you want to Print & Send the sheet?", vbYesNo + vbQuestion, "Empty Sheet")
If answer = vbYes Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Retail Order Sheet"
.Body = "Hi Andy, Please order."
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Range("A1:N25").Select
ActiveSheet.PageSetup.PrintArea = "$A$1:$N$25"
oldprinter = Application.ActivePrinter
For i = 0 To 15
curNePrint = Format(i, "00")
On Error Resume Next
Application.ActivePrinter = "\\10.17.0.9\CCFN_Retail_MFP_BW on Ne" & curNePrint & ":"
Next i
ActiveWindow.Selection.PrintOut Copies:=1
Application.ActivePrinter = oldprinter
On Error GoTo 0
Else
End If
End Sub
Assuming the rows' location on the destination worksheet is determined by examining the same column as the one containing the worksheet names, something like the following might do the trick.
The DispatchRows sub scans prngWorksheetNames, looking for worksheets that exist by name.
You must call DispatchRows by passing it the range containing the worksheet names. For example, if the source worksheet names are on worksheet Summary, range C2:C50, you'd call DispatchRows ThisWorkbook.Worksheets("Summary").Range("C2:C50").
Option Explicit
'Copies entire rows to worksheets whose names are found within prngWorksheetNames.
'ASSUMPTION: on the destination worksheet, a copied row is appended at the lowest empty spot in the same column as prngWorksheetNames.
Public Sub DispatchRows(ByVal prngWorksheetNames As Excel.Range)
Dim lRow As Long
Dim rngWorksheetName As Excel.Range
Dim sDestWorksheetTabName As String
Dim oDestWs As Excel.Worksheet
Dim bScreenUpdating As Boolean
Dim bEnableEvents As Boolean
On Error GoTo errHandler
bScreenUpdating = Application.ScreenUpdating
bEnableEvents = Application.EnableEvents
Application.ScreenUpdating = False
Application.EnableEvents = False
For lRow = 1 To prngWorksheetNames.Rows.Count
Set rngWorksheetName = prngWorksheetNames.Cells(lRow, 1)
sDestWorksheetTabName = CStr(rngWorksheetName.Value)
If TryGetWorksheetByTabName(ThisWorkbook, sDestWorksheetTabName, oDestWs) Then
'Make sure there are no active autofilters on the destination worksheet, as they would typically interfere with the copy operation.
If oDestWs.FilterMode Then
oDestWs.ShowAllData
End If
'Copy and paste.
rngWorksheetName.EntireRow.Copy
oDestWs.Cells(oDestWs.Rows.Count, prngWorksheetNames.Column).End(xlUp).Offset(1).EntireRow.PasteSpecial xlPasteAll
End If
Next
Cleanup:
On Error Resume Next
Set rngWorksheetName = Nothing
Set oDestWs = Nothing
Application.CutCopyMode = False
Application.EnableEvents = bEnableEvents
Application.ScreenUpdating = bScreenUpdating
Exit Sub
errHandler:
MsgBox Err.Description, vbExclamation + vbOKOnly, "Error"
Resume Cleanup
End Sub
'Returns True, and a reference to the target worksheet, if worksheet psName is found by name on pwbkHost.
Public Function TryGetWorksheetByTabName(ByVal pwbkHost As Excel.Workbook, ByVal psName As String, ByRef pshtResult As Excel.Worksheet) As Boolean
Set pshtResult = Nothing
On Error Resume Next
Set pshtResult = pwbkHost.Worksheets(psName)
TryGetWorksheetByTabName = Not pshtResult Is Nothing
End Function
Here is very simple script to achieve what you want. Insert in your code appropriately, or call it from your macro. I tested this many times to make sure it works.
Sub CopyLines()
Dim mySheet
Dim LastRow As Long
Dim LastShtRow As Long
Dim j
LastRow = Sheets("Order Sheet").Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To LastRow Step 1
mySheet = Range("B" & j).Value
LastShtRow = Sheets(mySheet).Cells(Rows.Count, 1).End(xlUp).Row
Range("A" & j & ":" & "N" & j).Copy
Sheets(mySheet).Range("A" & LastShtRow + 1).PasteSpecial xlPasteValues
Next j
Application.CutCopyMode = False
End Sub

Opening Outlook through VBA crashes for unknown reason

I am using this code to open a list of email-adresses directly in outlook. The email list consists of roughly 100 email-adresses.
If I let the code run for only parts of the list it works just fine for all different parts, but as soon as I let it run for the whole list I get a runtime error '5. Does anyone have a suggestion what causes this problem? I would be very thankful.
If ActiveWorkbook.Worksheets("Output").Range("I10").Value = "Wahr" Then
Dim strAddress As String
Dim lastCell As Long
Dim i As Integer
Worksheets("Output").Activate
lastCell = Range("B" & Rows.Count).End(xlUp).Row
For i = 13 To lastCell
If strAddress = "" Then
strAddress = Cells(i, 2).Value
Else
strAddress = strAddress & ";" & Cells(i, 2).Value
End If
Next i
ActiveWorkbook.FollowHyperlink Address:="mailto:" & strAddress 'this line gives me the error
End If
EDIT: The weird thing is, that it doesnt really matter which "groups" I choose. It seems to be a question of how many adresses I pick.
Not sure what you mean by I am using this code to open a list of email-adresses directly in outlook.
The code appears to create a single blank email with each cell in B13 downwards providing the email addresses?
Maybe this code below will help.
It uses late binding (so no references needed) to get a reference to Outlook, it then creates an email and adds the email addresses to it as recipients before finally displaying it. You can change the .Display to .Send to send the email rather than just display it.
Public Sub Test()
Dim oOL As Object
Dim oMail As Object
Dim rLastCell As Range
Dim rAddRange As Range
Dim rCell As Range
Set oOL = CreateOL
With ThisWorkbook.Worksheets("Output")
Set rLastCell = .Cells(.Rows.Count, 2).End(xlUp)
Set rAddRange = .Range("B13", rLastCell)
End With
Set oMail = oOL.CreateItem(0)
With oMail
For Each rCell In rAddRange
.Recipients.Add rCell.Value
Next rCell
.Display
End With
End Sub
Public Function CreateOL() As Object
Dim oTmpOL As Object
On Error GoTo ERROR_HANDLER
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Creating an instance of Outlook is different from Excel. '
'There can only be a single instance of Outlook running, '
'so CreateObject will GetObject if it already exists. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set oTmpOL = CreateObject("Outlook.Application")
Set CreateOL = oTmpOL
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreateOL."
Err.Clear
End Select
End Function

Filter and Email Excel File (VBA)

I have a list of accounts and relevant information that I have to split up and send specific accounts to certain people. This has to be done about 50 times. I already have a program setup that will filter, copy the data to a new file, and save. Is there a way to set it up to then email this file based on a list of contacts?
Each account is covered by a region, so I have a list which has the region and the contact's email. In the macro that splits by the regions, it has an array of these regions so is some kind of lookup possible from the list of contacts?
Code:
Sub SplitFile()
Dim rTemp As Range
Dim regions() As String
Set rTemp = ThisWorkbook.Sheets("Combined").Range("AH2:AH1455")
regions = UniqueItems(rTemp, False)
For N = 1 To UBound(regions)
Set wb = Workbooks.Add
ThisWorkbook.Sheets("DVal").Copy _
after:=ActiveWorkbook.Sheets("Sheet1")
With ThisWorkbook.Sheets("Combined")
.AutoFilterMode = False
' .AutoFilter
.Range("A1:BP1455").AutoFilter Field:=34, Criteria1:=regions(N)
Application.DisplayAlerts = False
.Range("A1:BP1455").Copy wb.Sheets("Sheet1").Range("A1")
Application.DisplayAlerts = True
For c = 1 To 68
wb.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = .Columns(c).ColumnWidth
Next c
End With
With wb
.Sheets("Sheet1").Activate
.SaveAs Filename:="H:\" & regions(N) & " 14-12-11"
.Close True
End With
Set wb = Nothing
Next N
End Sub
I am assuming you want to do it programmaticaly using VB, you can do something like
Dim msg As System.Web.Mail.MailMessage = New System.Web.Mail.MailMessage()
msg.From = "noone#nobody.com"
msg.To = "someone#somewhere.com"
msg.Subject = "Email with Attachment Demo"
msg.Body = "This is the main body of the email"
Dim attch As MailAttachment = New MailAttachment("C:\attachment.xls")
msg.Attachments.Add(attch)
SmtpMail.Send(msg)
If you're having trouble with the above, my mail macro is different; this is used with excel 2007:
Sub Mail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "To Whom It May Concern:" & vbNewLine & vbNewLine & _
"This is a test!" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.to = "anyone#anywhere.com"
.cc = ""
.BCC = ""
.Subject = "This is only a test"
.Body = strbody
'You can add an attachment like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Jon
I am assuming the following.
1) Regions are in Col AH
2) Contacts are in Col AI
3) UniqueItems() in your code removes duplicates?
Please try the below code. I have commented the code so please go through them and make relevant changes. Especially to the part where you save the File. I have used Late Binding with Outlook.
NOTE: I always test my code before posting but in the current scenario I cannot so do let me know if you find any errors.
Option Explicit
Sub SplitFile()
'~~> Excel variables
Dim wb As Workbook, wbtemp As Workbook
Dim rTemp As Range, rng As Range
Dim regions() As String, FileExt As String, flName As String
Dim N As Long, FileFrmt As Long
'~~> OutLook Variables
Dim OutApp As Object, OutMail As Object
Dim strbody As String, strTo As String
On Error GoTo Whoa
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
'~~> Just Regions
Set rTemp = wb.Sheets("Combined").Range("AH2:AH1455")
'~~> Regions and Email address. We wil require this later
'~~> Tofind email addresses
Set rng = wb.Sheets("Combined").Range("AH2:AI1455")
regions = UniqueItems(rTemp, False)
'~~> Create an instance of outlook
Set OutApp = CreateObject("Outlook.Application")
For N = 1 To UBound(regions)
Set wb1 = Workbooks.Add
wb.Sheets("DVal").Copy after:=wb1.Sheets(1)
With wb.Sheets("Combined")
.AutoFilterMode = False
With .Range("A1:BP1455")
.AutoFilter Field:=34, Criteria1:=regions(N)
'~~> I think you want to copy the filtered data???
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy _
wb1.Sheets("Sheet1").Range("A1")
For c = 1 To 68
wb1.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = _
wb.Columns(c).ColumnWidth
Next c
End With
End With
'~~> Set the relevant Fileformat for Save As
' 51 = xlOpenXMLWorkbook (without macro's in 2007-2010, xlsx)
' 52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2010, xlsm)
' 50 = xlExcel12 (Excel Binary Workbook in 2007-2010 with or without macro's, xlsb)
' 56 = xlExcel8 (97-2003 format in Excel 2007-2010, xls)
FileFrmt = 52
Select Case FileFrmt
Case 50: FileExt = ".xlsb"
Case 51: FileExt = ".xlsx"
Case 52: FileExt = ".xlsm"
Case 56: FileExt = ".xls"
End Select
'~~> Contruct the file name.
flName = "H:\" & regions(N) & " 14-12-11" & FileExt
'~~> Do the save as
wb1.SaveAs Filename:=flName, FileFormat:=FileFrmt
wb1.Close SaveChanges:=False
'~~> Find the email address
strTo = Application.WorksheetFunction.VLookup(regions(N), rng, 2, 0)
'~~> Create new email item
Set OutMail = OutApp.CreateItem(0)
'~~> Create the body of the email here. Change as applicable
strbody = "Dear Mr xyz..."
With OutMail
.To = strTo
.Subject = regions(N) & " 14-12-11" '<~~ Change subject here
.Body = strbody
.Attachments.Add flName
'~~> Uncomment the below if you just want to display the email
'~~> and comment .Send
'.Display
.Send
End With
Next N
LetContinue:
Application.ScreenUpdating = True
'~~> CleanUp
On Error Resume Next
Set wb = Nothing
Set wb1 = Nothing
Set OutMail = Nothing
OutApp.Quit
Set OutApp = Nothing
On Error GoTo 0
Whoa:
MsgBox Err.Description
Resume LetContinue
End Sub