so I have set up an emailing system in which emails are sent out to people that own a specific item that have a due date coming up. There are at least 1,000 items on my excel sheet and each item has a specific owner. However the owners are labeled using an ID. The ID refers to an email address in another sheet called "Permissions" . My email function works, however I am having trouble with my recepients. I am not able to match the ID on the sheet that has the items to the email address in the other sheet. I am fairly new to VBA so please excuse my code. I am still learning. Thank you!
The worksheet name "Register" is the worksheet with all of the items and due dates.
Code :
Option Explicit
Sub TestEmailer()
Dim Row As Long
Dim lstRow As Long
Dim Message As Variant
Dim Frequency As String 'Cal Frequency
Dim DueDate As Date 'Due Date for Calibration
Dim vbCrLf As String 'For HTML formatting
Dim registerkeynumber As String 'Register Key Number
Dim class As Variant 'Class
Dim owner As String ' Owner
Dim status As String 'Status
Dim ws As Worksheet
Dim toList As Variant
Dim Ebody As String
Dim esubject As String
Dim Filter As String
Dim LQAC As String
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Set ws = Sheets(1)
ws.Select
lstRow = WorksheetFunction.Max(2, ws.Cells(Rows.Count, Range("CalDueDate").Column).End(xlUp).Row)
For Row = 2 To lstRow
DueDate = CDate(Worksheets("Register").Cells(Row, Range("DueDate").Column).Value) 'DUE DATE
registerkeynumber = Worksheets("Register").Cells(Row, Range("RegisterKey").Column).Value
class = Worksheets("Register").Cells(Row, Range("Class").Column).Value
status = Worksheets("Register").Cells(Row, Range("Status").Column).Value
LQAC = Worksheets("Register").Cells(Row, Range("LQAC").Column).Value
Filter = Worksheets("Permissions").Cells(Row, Worksheets("Permissions").Range("MailFilter").Column).Value
If DueDate - Date <= 7 And class > 1 And status = "In Service" And DueDate <> "12:00:00 AM" Then
vbCrLf = "<br><br>"
'THIS IS WHERE I AM NOT SURE IF I AM REFERENCING CORRECTLY. I AM NOT SURE HOW TO REFERENCE THE ID FROM THE 'REGISTER' AND MATCH IT WITH THE EMAIL ADDRESS IN THE 'PERMISSIONS' WORKSHEET. AS OF NOW I AM ONLY REFERENCING THE EMAIL ADDRESS BUT THEY ARE NOT MATCHING UP.
toList = Worksheets("Permissions").Cells(Row, Worksheets("Permissions").Range("Email").Column).Value 'RECEPIENT OF EMIAL
esubject = "TEXT " & Cells(Row, Range("Equipment").Column).Value & " is due in the month of " & Format(DueDate, "mmmm-yyyy")
Ebody = "<HTML><BODY>"
Ebody = Ebody & "Dear " & Cells(Row, Range("LQAC").Column).Value & vbCrLf
Ebody = Ebody & "</BODY></HTML>"
SendEmail Bdy:=Ebody, Subjct:=esubject, Two:=toList
End If
Next Row
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Function SendEmail(Bdy As Variant, Subjct As Variant, Optional Two As Variant = "Email#xxx", Optional ReplyTo As Variant = "Email#xxx", Optional Carbon As Variant = "Email#xxx", Optional Attch As Variant = "FilePath", Optional Review As Boolean = False)
Dim OutlookEM As Outlook.Application
Dim EMItem As MailItem
If Not EmailActive Then Exit Function
If Two = "Email#xxx" Then
MsgBox "There is no Address to send this Email"
Two = ""
Review = True
'Exit Function
End If
'Create Outlook object
Set OutlookEM = CreateObject("Outlook.Application")
'Create Mail Item
Set EMItem = OutlookEM.CreateItem(0)
With EMItem
.To = Two
.Subject = Subjct
.HTMLBody = Bdy
End With
If ReplyTo <> "Email#xxx" Then EMItem.ReplyRecipients.Add ReplyTo
If Attch <> "FilePath" Then EMItem.Attachments.Add Attch
If Carbon <> "Email#xxx" Then EMItem.CC = Carbon
If Review = True Then
EMItem.Display (True)
Else
EMItem.Display
' EMItem.Send
End If
End Function
I think I am able to follow what the issue is here. It doesn't look like your code is using any vlookup formula or matching formula to find the email. Unless they are on the same row between the different sheets, you will need to find the value.
VBA has the ability to use the functions that you would normally use in Excel.
If you tweek the code below with the correct range and column number, you should be able to find the correct email address based on an ID.
' instead of 1 below, use the column for the id to look up
lookupValue = Worksheets("Register").Cells(Row, 1).Value
' range of the ids and emails in the permissions table - edit whatever the range should be
Rng = Worksheets("Permissions").Range("A1:B100")
' column to look up - number of columns between the id and email in the permissions tab
col = 2
' whether you want excel to try to find like match for the lookup value
' pretty much never have this be true if you want to have confidence in the result
likeMatch = False
emailAddress = WorksheetFunction.VLookup(lookupValue, Rng, col, likeMatch)
Related
I am building a tool which is required to look up the GAL in Outlook to find a certain employee and return their email address, their manager & manager's email address & finally their manager & manager's email address.
I found code and adjusted it to search for a person's name; however, if you have two Bob Smiths I require this to be more specific in its search, either by email address or by alias.
Any code I found creates an array with all users in the exchange server; however, with millions of employee records this takes a large amount of time and this would run once per week to update the information.
Is there a way to search ideally by alias or secondly by SMTP email address?
I found versions of the code and I modified them to suit my requirements but still unable to find by alias or email address. If I do this manually I can click on advance search and type the alias or I click on "more columns" and search the alias and the correct result appears.
Can I define "More Columns" in the VBA code?
Dim myolApp As Outlook.Application
Dim myNameSpace As Namespace
Dim myAddrList As AddressList
Dim myAddrEntry As AddressEntry
Dim AliasName As String
Dim i As Integer, r As Integer
Dim c As Range
Dim EndRow As Integer, n As Integer
Dim exchUser As Outlook.ExchangeUser
Set myolApp = CreateObject("Outlook.Application")
Set myNameSpace = myolApp.GetNamespace("MAPI")
Set myAddrList = myNameSpace.AddressLists("Global Address List")
Dim FullName As String, LastName As String, FirstName As String
Dim LDAP As String, PhoneNum As String
Dim StartRow As Integer
EndRow = Cells(Rows.Count, 1).End(xlUp).Row
StartRow = 2
For Each c In Range("I" & StartRow & ":I" & CStr(EndRow))
AliasName = LCase(Trim(c))
c = AliasName
Set myAddrEntry = myAddrList.AddressEntries(AliasName)
Set exchUser = myAddrEntry.GetExchangeUser
If Not exchUser Is Nothing Then
c.Offset(0, 1) = exchUser.FirstName
c.Offset(0, 2) = exchUser.LastName
c.Offset(0, 3) = exchUser.Alias
c.Offset(0, 4) = exchUser.PrimarySmtpAddress
c.Offset(0, 5) = exchUser.Manager
'etc...
End If
Next c
Have you checked the CreateRecipient namespace? https://learn.microsoft.com/en-us/office/vba/api/outlook.namespace.createrecipient
You could try creating a recipient object passing the alias to the CreateRecipient method:
Set myNamespace = Application.GetNamespace("MAPI")
Set recip = myNamespace.CreateRecipient("YourAlias")
recip.Resolve
You should of course check if your recipient was properly resolved by checking the resolved property:
If recip.Resolved Then
'Do something
After you got your recipient you can create an Exchange User from it using the GetExchangeUser method from the AdressEntry property in your recipient object.
Set exchUser = recip.AddressEntry.GetExchangeUser
Debug.Print exchUser.PrimarySmtpAddress
And I'm sure you can work it out from there!
I have been able to find a work around solution with the following function.
Function GetName(strAcc As String) As Variant
Dim lappOutlook As Outlook.Application
Dim lappNamespace As Outlook.Namespace
Dim lappRecipient As Outlook.Recipient
'Dim strAcc As String
Dim maxTries As Long
Dim errCount As Long
Set lappOutlook = CreateObject("Outlook.Application")
Set lappNamespace = lappOutlook.GetNamespace("MAPI")
Set lappRecipient = lappNamespace.CreateRecipient(strAcc)
maxTries = 2000
On Error GoTo errorResume
Retry:
DoEvents
' For testing error logic. No error with my Excel 2013 Outlook 2013 setup.
' Should normally be commented out
'Err.Raise 287
lappRecipient.Resolve
On Error GoTo 0
Set olAddrEntry = lappRecipient.AddressEntry
If lappRecipient.Resolved Then
Set olexchuser = olAddrEntry.GetExchangeUser
GetName = olexchuser.Name
Else
GetName = "Unable To Validate LDAP"
End If
ExitRoutine:
Set lappOutlook = Nothing
Set lappNamespace = Nothing
Set lappRecipient = Nothing
Exit Function
errorResume:
errCount = errCount + 1
' Try until Outlook responds
If errCount > maxTries Then
' Check if Outlook is there and Resolve is the issue
lappNamespace.GetDefaultFolder(olFolderInbox).Display
GoTo ExitRoutine
End If
'Debug.Print errCount & " - " & Err.Number & ": " & Err.Description
Resume Retry
End Function
Is there a way to return the following Exchange Values to consolidate the function so it only looks in the exchange server once ?
Obtain .Name
.PrimarySmtpAddress
.Manager
.Manager.PrimarySmtpAddress
.Manager.Alias
I then loop through and Get Managers, Manager & Email.
I use the following SUB to be able to pull the information needed (Into a message box while building but the data will populate a table once finished).
Sub GetDetails()
Dim Name As String, Email As String, Manager As String, ManagersEmail As String, MD As String, MDEmail As String, Lookup As String
Lookup = GetManagerAlias("3511931") '("3359820")
Name = GetName(Lookup)
Email = GetEmail(Lookup)
Manager = GetManager(Lookup)
ManagersEmail = GetManagersEmail(Lookup)
MD = GetManager(GetManagerAlias(Lookup))
MDEmail = GetManagersEmail(GetManagerAlias(Lookup))
MsgBox Name & vbNewLine & Email & vbNewLine & Manager & vbNewLine & ManagersEmail & vbNewLine & MD & vbNewLine & MDEmail
End Sub
I have the following code to try and grab the GAL from Outlook and drop the person's name + their email address into another sheet.
It gets the first name (but not email address) then stops. If I comment out Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.PrimarySmtpAddress, it lists all the names succesfully, which suggests I might be using the wrong type to get the email address. VBA has no intellisense though so I'm not sure what to use instead!
Private Sub UpdateEmails()
' Need to add reference to Outlook
' Adds addresses to existing Sheet called Emails and
' defines name NamesAndEmailAddresses containing this list
On Error GoTo error
Dim objOutlook As Outlook.Application
Dim objAddressList As Outlook.AddressList
Dim objAddressEntry As Outlook.AddressEntry
Dim intCounter As Integer
Application.ScreenUpdating = False
' Setup connection to Outlook application
Set objOutlook = CreateObject("Outlook.Application")
Set objAddressList = objOutlook.Session.AddressLists("Global Address List")
Application.EnableEvents = False
' Clear existing list
Sheets("Emails").Range("A:A").Clear
'Step through each contact and list each that has an email address
For Each objAddressEntry In objAddressList.AddressEntries
If objAddressEntry.Address <> "" Then
intCounter = intCounter + 1
Application.StatusBar = "Processing no. " & intCounter & " ... " & objAddressEntry.Address
Sheets("Emails").Cells(intCounter, 1) = objAddressEntry.Name
Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.PrimarySmtpAddress
DoEvents
End If
Next objAddressEntry
' Define range called "NamesAndEmailAddresses" to the list of emails
Sheets("Emails").Cells(1, 2).Resize(intCounter, 1).Name = "NamesAndEmailAddresses"
error:
Set objOutlook = Nothing
Application.StatusBar = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Looking at the AddressEntry Object (Outlook) page on MSDN, the property you want is AddressEntry.Address
Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.Address
Also, if you early-bind Outlook from the Tools > References...* then you will get Intellisense. Or, you can hit [Alt]+[F11] in Outlook and use the Intellisense there.
{EDIT} Since this is giving the path on the Exchange Server rather than as a full e-mail address
If the Contact is in an Exchange Address List, then you can use .GetExchangeUser.PrimarySmtpAddress to get the Primary Smtp Address for the user on the Exchange Server. (For local contacts on your account, use the GetContact.Email1Address instead)
Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.GetExchangeuser.PrimarySmtpAddress
To obtain or check if a person has an email address on the GAL:
(see this solution)
Sub testGetEmail()
Debug.Print GetEmailName("Dupont", "Alain")
End Sub
Function GetEmailName(FirstName As String, SecondName As String) As String
Dim oExUser As Outlook.ExchangeUser
Dim oAL As Outlook.AddressList
Set oAL = Application.Session.AddressLists.Item(["Global Address List"])
FullName = FirstName & ", " & SecondName
Set oExUser = oAL.AddressEntries.Item([FullName]).GetExchangeUser
GetEmailName = oExUser.PrimarySmtpAddress
End Function
I am using the following VBA code to try and copy a range from a workbook and paste this into an email:
This is the piece of code causing the issue. Error 438 'object doesn't support this property or method' on this line:
WB3.Range("A20:J30").SpecialCells (xlCellTypeVisible)
Code:
'Insert Range
Dim app As New Excel.Application
app.Visible = False
'open a workbook that has same name as the sheet name
Set WB3 = Workbooks.Open(Range("F" & i).value)
'select cell A1 on the target book
WB3.Range("A20:J30").SpecialCells (xlCellTypeVisible)
Call stream.WriteText(rangetoHTML(rng))
If i use ThisWorkbook, seems to work fine. It's something wrong with how i am defining the other workbook.
My cells in column F all contain valid paths like:
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\test\Accrol.xlsx
Pleas can someone show me where i am going wrong? Ideally i would rather get the range from the workbook without having to open it, but alas i am brand new to vba so not sure if this would work.
The aim is to get the range put into the body of an email.
Call stream.WriteText(rangetoHTML(rng))
Full Code:
Sub Send()
Dim answer As Integer
answer = MsgBox("Are you sure you want to Send All Announcements?", vbYesNo + vbQuestion, "Notice")
If answer = vbNo Then
Exit Sub
Else
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim Attachment As String
Dim WB3 As Workbook
Dim WB4 As Workbook
Dim rng As Range
Dim db As Object
Dim doc As Object
Dim body As Object
Dim header As Object
Dim stream As Object
Dim session As Object
Dim i As Long
Dim j As Long
Dim server, mailfile, user, usersig As String
Dim LastRow As Long, ws As Worksheet
LastRow = Worksheets(1).Range("F" & Rows.Count).End(xlUp).Row 'Finds the last used row
j = 18
With ThisWorkbook.Worksheets(1)
For i = 18 To LastRow
'Start a session of Lotus Notes
Set session = CreateObject("Notes.NotesSession")
'This line prompts for password of current ID noted in Notes.INI
Set db = session.CurrentDatabase
Set stream = session.CreateStream
' Turn off auto conversion to rtf
session.ConvertMime = False
'Email Code
'Create email to be sent
Set doc = db.CreateDocument
doc.Form = "Memo"
Set body = doc.CreateMIMEEntity
Set header = body.CreateHeader("Promotion Announcement for week " & Range("I8").value & ", " & Range("T8").value & " - Confirmation required")
Call header.SetHeaderVal("HTML message")
'Set From
Call doc.ReplaceItemValue("Principal", "Food Specials <mailto:Food.Specials#Lidl.co.uk>")
Call doc.ReplaceItemValue("ReplyTo", "Food.Specials#Lidl.co.uk")
Call doc.ReplaceItemValue("DisplaySent", "Food.Specials#Lidl.co.uk")
'To
Set header = body.CreateHeader("To")
Call header.SetHeaderVal(Range("Q" & i).value)
'Email Body
Call stream.WriteText("<HTML>")
Call stream.WriteText("<font size=""3"" color=""black"" face=""Arial"">")
Call stream.WriteText("<p>Good " & Range("A1").value & ",</p>")
Call stream.WriteText("<p>Please see attached an announcement of the spot buy promotion for week " & Range("I8").value & ", " & Range("T8").value & ".<br>Please check, sign and send this back to us within 24 hours in confirmation of this order. Please also inform us of when we can expect the samples.</p>")
Call stream.WriteText("<p>The details are as follows:</p>")
'Insert Range
Dim app As New Excel.Application
app.Visible = False
'open a workbook that has same name as the sheet name
Set WB3 = Workbooks.Open(Range("F" & i).value)
'select cell A1 on the target book
WB3.Range("A20:J30").SpecialCells (xlCellTypeVisible)
Call stream.WriteText(rangetoHTML(rng))
Call stream.WriteText("<p><b>N.B. A volume break down by RDC will follow 4/5 weeks prior to the promotion. Please note that this is your responsibility to ensure that the orders you receive from the individual depots match the allocation.</b></p>")
Call stream.WriteText("<p>We also need a completed Product Technical Data Sheet. Please complete this sheet and attach the completed sheet in your response.</p>")
'Attach file
Attachment = Range("F" & i).value
Set AttachME = doc.CREATERICHTEXTITEM("attachment")
Set EmbedObj = AttachME.EmbedObject(1454, "", Attachment, "")
Call stream.WriteText("<BR><p>Please note the shelf life on delivery should be 75% of the shelf life on production.</p></br>")
'Signature
Call stream.WriteText("<BR><p>Kind regards / Mit freundlichen Grüßen,</p></br>")
Call stream.WriteText("<p><b>Lidl UK Food Specials Team</b></p>")
Call stream.WriteText("<table border=""0"">")
Call stream.WriteText("<tr>")
Call stream.WriteText("<td><img src=""http://www.lidl.co.uk/statics/lidl-uk/ds_img/layout/top_logo2016.jpg"" alt=""Mountain View""></td>")
Call stream.WriteText("<td><img src=""http://www.lidl.co.uk/statics/lidl-uk/ds_img/assets_x_x/BOQLOP_NEW%281%29.jpg"" alt=""Mountain View""></td>")
Call stream.WriteText("</tr>")
Call stream.WriteText("</table>")
Call stream.WriteText("</font>")
Call stream.WriteText("</body>")
Call stream.WriteText("</html>")
Call body.SetContentFromText(stream, "text/HTML;charset=UTF-8", ENC_IDENTITY_7BIT)
Call doc.Send(False)
session.ConvertMime = True ' Restore conversion - very important
'Clean Up the Object variables - Recover memory
Set db = Nothing
Set session = Nothing
Set stream = Nothing
Set doc = Nothing
Set body = Nothing
Set header = Nothing
WB3.Close savechanges:=False
Application.CutCopyMode = False
'Email Code
j = j + 1
Next i
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Success!" & vbNewLine & "Announcements have been sent."
End If
End Sub
WB3 is a Workbook object. Workbooks don't support the range property. Instead, use a worksheet object.
Example
WB3.Sheets(1).Range("A20:J30").SpecialCells(xlCellTypeVisible)
This line on it's own does not do anything. If you want to select these cells call the select method:
WB3.Sheets(1).Range("A20:J30").SpecialCells(xlCellTypeVisible).Select
EDIT
Just noticed that #Slai had already identified the root cause, in the comments.
I've been trying to create a sub that would take some information from an Excel selection and create a new task on Outlook. The body of the task should feature the comment from the first cell (which it already does) but before all that I want to paste the range as it looks in Excel, then the comment, and then again, the range.
Here's my code:
Sub CreateReminder()
Dim olApp As Object
Dim olRem As Object
Dim myRange As Range
Dim contact As String
Dim company As String
Dim city As String
Dim state As String
Dim cmt As comment
Dim comment As String
Dim strdate As Date
Dim remdate As Date
Set olApp = CreateObject("Outlook.Application")
Set olRem = olApp.CreateItem(3)
Set myRange = Selection
If ActiveCell.comment Is Nothing Then
Exit Sub
Else
Set cmt = ActiveCell.comment
End If
company = myRange.Columns(1).Text
contact = myRange.Columns(2).Text
If InStr(contact, "/") <> 0 Then
contact = Left(contact, InStr(contact, "/") - 1)
End If
city = myRange.Columns(7).Text
state = myRange.Columns(8).Text
myRange.Copy
comment = cmt.Text
strdate = Date
remdate = Format(Now)
rangeaddress = myRange.Address
wrksheetname = ActiveSheet.Name
With olRem
.Subject = "Call " & contact & " - " & company & " - " & city & ", " & state
.display
SendKeys "{TAB 9}"
SendKeys "^{v}"
.body = Chr(10) & comment & Chr(10)
'.startdate = strdate
'.remindertime = remdate
'.reminderset = True
'.showcategoriesdialog
End With
Set olApp = Nothing
Set olRem = Nothing
End Sub
As you can see, I am able to paste using a SendKeys method, but it is sort of a hack, and not... sophisticated. I'm sure there's another way of doing it, any ideas?
I found code for pasting as HTML to an email, but as I understand, the Mail item allows for HTML, but not the Task item.
Outlook uses Word as an email editor. You can use the Word object model for making manipulatins on the message body. The WordEditor property of the Inspector class returns an instance of the Document class (from the Word object model) which represents the body. You can read more about that way and all possible ways in the Chapter 17: Working with Item Bodies.
That way you can use the Copy method of the Range class to copy the range to the Clipboard. Then you can use the Paste method from the Word object model to paste data into the document which represents the message body.
I've built a userform that allows modification of a macro-generated string before it becomes part of a new spreadsheet. As written, I have one worry about how resilient it will be.
The form has a single textbox called CourseDescription into which a string value strBundleDescription is dumped:
frmDescriptionReview.CourseDescription = strBundleDescription
frmDescriptionReview.CourseDescription.MultiLine = True
frmDescriptionReview.CourseDescription.WordWrap = True
frmDescriptionReview.Show
The user can then edit the text as needed and press OK to pass the text to the spreadsheet being created.
On clicking OK, the modified string is placed in Range("B7") of the spreadsheet:
Private Sub cmdOK_Click()
Dim strValue As String
strValue = CourseDescription.Value
If strValue <> "" Then
Range("B7").Value = strValue
End If
Unload Me
End Sub
This works so far in practice, but I've had unexplained focus issues before. I am concerned that the focus might in some (unknown) circumstance shift to another open worksheet and the text will be pasted where it does not belong.
My question: Am I right to want a more defined location, or will a simple range definition like the one above be adequate? And if a more defined location is advised, is there a way to pass information like the wkbSaba and shtCourse values without making public variables?
All potential solutions I found involved some form of public variable, but on principle (rightly or wrongly) I'm trying to avoid public variables when information will only be used in one function (as in this case).
Full Code, as requested: This is the the full macro code as it stands. The call for frmDescriptionReview is about 3/4 of the way down under the comment tag "'enter base information for Bundle Description".
I'm going to try the Property call as you suggest, which is something I did not know about, and had not seen when web searching for ways to pass data to a userform. So much to learn! It certainly looks like the variables could be passed that way.
Option Explicit
Sub TransferData()
'***************************************
' TO USE THIS MACRO:
' 1. Make sure that all information for the bundle is included
' on the 'km notification plan' and 'bundle details (kbar)' tabs
' of the Reporting_KMFramework.xlsx
' 2. Select the bundle name on the 'km notification plan' tab.
' 3. Start the macro and it should create the basis of the Saba
' form
' 4. Read through the entire form, especially the bundle
' description, to be sure it is complete and accurate.
'***************************************
'establish variables
Dim iRow As Integer
Dim sTxt As String
Dim sTxt2 As String
Dim sBundleName As String
Dim sNumber As String
Dim aSplit() As String
Dim aSplit2() As String
Dim aBundleSplit() As String
Dim aNumberSplit() As String
Dim wkbFramework As Workbook
Dim wkbSaba As Workbook
Dim shtPlan As Worksheet
Dim shtCourse As Worksheet
Dim vData As Variant
Dim vBundleName As Variant
Dim lLoop As Long
'set initial values for variables
'find current row number
iRow = ActiveCell.Row
'remember locations of current data
Set wkbFramework = ActiveWorkbook
Set shtPlan = ActiveSheet
'Set rngSelect = Range("B" & iRow)
'select bundle name
vBundleName = shtPlan.Range("B" & iRow).Value
vData = vBundleName
sBundleName = shtPlan.Range("B" & iRow).Value
'find and save course names for the bundle
Sheets(2).Select
sTxt = Find_Range(vBundleName, Columns("B"), xlValues).Offset(0, 1).Value 'course names from Detail tab
sTxt2 = Find_Range(vBundleName, Columns("B"), xlValues).Offset(0, 2).Value 'course numbers from Detail tab
'open new Saba Form
Workbooks.Add Template:= _
"C:\Documents and Settings\rookek\Application Data\Microsoft\Templates\Bundle_SabaEntryForm_KM.xltm"
'remember locations of Saba form
Set wkbSaba = ActiveWorkbook
Set shtCourse = ActiveSheet
'move data into new Saba form
'paste bundle name
wkbSaba.Sheets(shtCourse.Name).Range("B5").Value = vData
'Transfer bundle number
vData = wkbFramework.Sheets(shtPlan.Name).Range("E" & iRow).Value
sNumber = vData
Dim aNumber() As String
aNumber = Split(sNumber, "-")
wkbSaba.Sheets(shtCourse.Name).Range("B6").Value = vData
'create names to use in the bundle description and (later) in naming the file
'Establish additional variables
Dim strDate As String
Dim strName1 As String
Dim strName2 As String
Dim strName3 As String
Dim strName4 As String
Dim strName5 As String
Dim aTechSplit() As String
Dim aCourse() As String
Dim iTech As Integer
'Dim iBundle As Integer
Dim iCourse As Integer
vData = wkbFramework.Sheets(shtPlan.Name).Range("L" & iRow).Value
aCourse = Split(sTxt, Chr(10))
iCourse = UBound(aCourse)
aTechSplit = Split(vData, " ")
iTech = UBound(aTechSplit)
aBundleSplit = Split(sBundleName, " ")
aNumberSplit = Split(sNumber, "-")
strName1 = aBundleSplit(0)
strName2 = aBundleSplit(1)
If UBound(aNumberSplit) > 1 Then
strName3 = aNumberSplit(UBound(aNumberSplit) - 1) & aNumberSplit(UBound(aNumberSplit))
End If
strName3 = Right(strName3, Len(strName3) - 1)
strName4 = aTechSplit(0) & " "
strName5 = aCourse(0)
For lLoop = 1 To iTech - 1
strName4 = strName4 & aTechSplit(lLoop) & " "
Next lLoop
If iCourse > 1 Then
For lLoop = 1 To iCourse - 1
strName5 = strName5 & ", " & aCourse(lLoop)
Next lLoop
strName5 = strName5 & ", and " & aCourse(iCourse)
End If
If iCourse = 1 Then
strName5 = strName5 & ", and " & aCourse(iCourse)
End If
strName5 = Replace(strName5, " Technical Differences", "")
strName5 = Replace(strName5, " Overview", "")
strName5 = Replace(strName5, " Technical Presales for ATCs", "")
strName5 = Replace(strName5, " Technical Presales for STCs", "")
strName5 = Replace(strName5, " Technical Presales", "")
'enter base information for Bundle Description
Dim strBundleDescription As String
strBundleDescription = "This Knowledge Maintenance bundle covers recent technology changes that may affect " & strName4 & "environments. Topics covered by this bundle include the enhancements and features introduced with " & strName5 & "."
'wkbSaba.Sheets(shtCourse.Name).Range("B7").Value = strBundleDescription
frmDescriptionReview.CourseDescription = strBundleDescription
frmDescriptionReview.CourseDescription.MultiLine = True
frmDescriptionReview.CourseDescription.WordWrap = True
frmDescriptionReview.Show
'transfer tech and track
wkbSaba.Sheets(shtCourse.Name).Range("B8").Value = vData
'transfer product GA date
vData = wkbFramework.Sheets(shtPlan.Name).Range("G" & iRow).Value
wkbSaba.Sheets(shtCourse.Name).Range("B9").Value = vData
'transfer bundle notification date
vData = wkbFramework.Sheets(shtPlan.Name).Range("D" & iRow).Value
wkbSaba.Sheets(shtCourse.Name).Range("B10").Value = vData
'set audience type
If aNumber(UBound(aNumber)) = "SA" Then
wkbSaba.Sheets(shtCourse.Name).Range("B11").Value = "Internal, Partner, Customer"
Else
wkbSaba.Sheets(shtCourse.Name).Range("B11").Value = "Internal, Partner"
End If
'set Education Manager
frmEducationManagerEntry.EducationManagers.MultiLine = True
frmEducationManagerEntry.EducationManagers.WordWrap = True
frmEducationManagerEntry.Show
'set EPG
wkbSaba.Sheets(shtCourse.Name).Range("B13").Value = "N/A (KM course reuse)"
'set Test information to N/A
wkbSaba.Sheets(shtCourse.Name).Range("A22:B22").Value = "N/A"
'enter course names
aSplit = Split(sTxt, Chr(10)) 'if there is more than one course, this establishes a number and location for each
If UBound(aSplit) > 4 Then
'add rows equal to the difference between ubound and 5
wkbSaba.Sheets(shtCourse.Name).Range("A21", "B" & 21 + (UBound(aSplit) - 5)).Select
Selection.EntireRow.Insert
End If
For lLoop = 0 To UBound(aSplit)
wkbSaba.Sheets(shtCourse.Name).Range("B" & 17 + lLoop).Value = aSplit(lLoop)
Next lLoop
'enter course numbers
aSplit2 = Split(sTxt2, Chr(10)) 'if there is more than one course, this establishes a number and location for each
For lLoop = 0 To UBound(aSplit2)
wkbSaba.Sheets(shtCourse.Name).Range("A" & 17 + lLoop).Value = Trim(aSplit2(lLoop))
Next lLoop
'save and close Saba form
With wkbSaba.Sheets(shtCourse.Name)
Dim SaveAsDialog As FileDialog
strDate = Date
strDate = Replace(strDate, "/", ".")
Set SaveAsDialog = Application.FileDialog(msoFileDialogSaveAs)
With SaveAsDialog
.Title = "Choose a file location and file name for your new Saba form"
.AllowMultiSelect = False
.InitialFileName = strName1 & strName2 & "_SabaEntryForm_" & strName3 & ".xlsx"
'.InitialFileName = sSavelocation & "\" & strName3 & "\" & aBundleSplit(0) & aBundleSplit(1) & "_" & strName3 & "_SabaEntryForm" & ".xlsx"
.Show
.Execute
End With
wkbSaba.Sheets(shtCourse.Name).PrintOut
wkbSaba.Close
End With
' Return focus to Plan sheet
shtPlan.Activate
End Sub
Addition of Property code fails
I tried adding code based on the property link shared in the comments, but running the code results in a Compile error: Method or data member not found. The complete userform code looks like this:
Option Explicit
Private wkbLocation As Workbook
Private shtLocation As Worksheet
Private Sub cmdCancel_Click()
Unload Me
End
End Sub
Private Sub cmdOK_Click()
Dim strValue As String
strValue = CourseDescription.Value
If strValue <> "" Then
wkbLocation.Sheets(shtLocation).Range("B7").Value = strValue
End If
Unload Me
End Sub
Property Let MyProp(wkbSaba As Workbook, shtCourse As Worksheet)
wkbLocation = wkbSaba
shtLocation = shtCourse
End Property
And the call for the userform now looks like this:
'enter base information for Bundle Description
Dim strBundleDescription As String
strBundleDescription = "This Knowledge Maintenance bundle covers recent technology changes that may affect " & strName4 & "environments. Topics covered by this bundle include the enhancements and features introduced with " & strName5 & "."
'wkbSaba.Sheets(shtCourse.Name).Range("B7").Value = strBundleDescription
Dim frmDescriptionReview As UserForm3
Set frmDescriptionReview = New UserForm3
frmDescriptionReview.MyProp = "Pass to form"
frmDescriptionReview.CourseDescription = strBundleDescription
frmDescriptionReview.CourseDescription.MultiLine = True
frmDescriptionReview.CourseDescription.WordWrap = True
frmDescriptionReview.Show
When I run the code, I get a Compile error: Method or data member not found, highlighting .MyProp. Help says this error means I misspelled the object or member name, or specified a collection index that is out of range. I checked the spelling, and MyProp is exactly how I spelled it in both locations. I don't think I'm specifying a collection am I? None are explicitly defined. What am i doing wrong?
I am concerned that the focus might in some (unknown) circumstance
shift to another open worksheet and the text will be pasted where it
does not belong.
Not really sure what you are asking. But you can further define your range variable by using:
Workbooks("Book1.xlsm").Worksheets("Sheet1").Range("B7").Value = strValue
or
Workbooks(wkbSaba).Worksheets(shtCourse).Range("B7").Value = strValue
That will ensure it goes to the right workbook and worksheet. I'm not sure why you think you need public variables?
EDIT:
UserForm Code:
Private wsSheet As Worksheet
Property Let SetWorksheet(wsSheetPass As Worksheet)
Set wsSheet = wsSheetPass
End Property
Private Sub cmdOK_Click()
Dim strValue As String
strValue = CourseDescription.Value
If strValue <> "" Then
wsSheet.Range("B7").Value = strValue
End If
Unload Me
End Sub
Calling Module:
Dim wsSheetToPass As Worksheet
Set wsSheetToPass = Workbooks(wkbSaba).Worksheets(shtCourse)
frmDescriptionReview.SetWorksheet = wsSheetToPass
As Reafidy states, creating a Property for the Userform and passing information to it would clearly be the right answer for passing variables to and from a userform.
Ideally what I want is to have the form very losely coupled with the module, and not touch the spreadsheet at all (so when appropriate I can pass information to the form from other modules, get the information returned, and place it where appropriate for the current module (which could be on an entirely different spreadsheet or in a completely different cell).
I found additional information on passing data with properties on the PeltierTech web site (http://peltiertech.com/Excel/PropertyProcedures.html) that helped me understand what Reafidy was doing so I couls start loosening the coupling between my code and my forms even more (which was my original intent for this question.
Adding the Get property allows the loose coupling I'm looking for, allowing me to both give and receive information without having to pass the spreadsheet data at all. So my call in the module now looks like this:
'review and revise Description Text
Dim DescriptionReview As New frmDescriptionReview
With DescriptionReview
.Description = strBundleDescription
.Show
strBundleDescription = .Description
End With
Unload DescriptionReview
'transfer description text
wkbSaba.Sheets(shtCourse.Name).Range("B7").Value = strBundleDescription
and the code for the UserForm itself becomes much simpler, like this:
Option Explicit
Property Let Description(ByVal TextBeingPassed As String)
Me.CourseDescription.Value = TextBeingPassed
End Property
Property Get Description() As String
Description = Me.CourseDescription.Value
End Property
Private Sub cmdOK_Click()
Me.Hide
End Sub
Private Sub cmdCancel_Click()
Unload Me
End
End Sub