Outlook Forms: Importing / VLOOKUP Data from Excel? - vba

I am a bit new to Outlook forms, but not to VBA overall - nor HTML/Web design of forms. However, my problem is finding a way to combine the two.
I am trying to design a form for users to fill out, and based on what they fill out in drop-down box's, it will then tell them what we want them to attach in the email. Currently we have this done in Excel, based on dropbox's it then VLOOKUPS to the 2nd Spreadsheet that contains the forms required.
Is there anyway I can bring in the Excel with the VLOOKUP behind the scenes in my VBA Outlook Form so that it can look-up what attachments we want the user to do? Otherwise, it would be a TON of SELECT CASE statements in VBA =/

This seems to the do the trick for me.
Some of it I have cobbled together from sites like this, the rest has been created by myself from scratch.
When I click my button:
An input box appears, which is the value that will be looked up in the spreadsheet.
it looks in the range (specified in the code), for a match
returns the value, two columns to the left of it.
when it finds a match it puts it in the Subject line in Outlook.
Dim jobno As String
Dim Proj As String
Sub Test()
jobno = InputBox("Job Number?", "Test")
GetNameFromXL
If jobno <> "" Then
Set myItem = Application.CreateItem(0)
If Proj <> "" Then
myItem.Subject = jobno & " - " & Proj & " - " & Format(Date, "dd.mm.yy")
Else
myItem.Subject = jobno & " - " & Format(Date, "dd.mm.yy")
End If
myItem.Display
Else
Exit Sub
End If
End Sub
Sub GetNameFromXL()
'Late binding. No reference to Excel Object required.
Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Set xlApp = CreateObject("Excel.Application")
'Open the spreadsheet to get data
Set xlWB = xlApp.Workbooks.Open("X:\...\FILENAME.xlsx") ' <-- Put your file path and name here
Set xlWS = xlWB.Worksheets(1) ' <-- Looks in the 1st Worksheet
Debug.Print "-----Start of 'For Each' loop"
For Each c In xlWS.Range("A6:A100") 'Change range to value you want to 'VLookUp'
Proj = c.Offset(0, 2).Value 'This looks at the 2nd column after the range above
Debug.Print c & Proj
If jobno = c Then
Debug.Print "-----Match Found: " & jobno & " = " & Proj
GoTo lbl_Exit
Else
End If
Next c
Debug.Print "-----End of For Each loop"
MsgBox jobno & " not found in WorkBook."
'Clean up
Set xlWS = Nothing
Set xlWB = Nothing
Set c = Nothing
Proj = ""
xlApp.Quit
Set xlApp = Nothing
lbl_Exit:
Exit Sub
End Sub

Related

Automated Export of Access Table-Data to Populate Template Excel Sheet

I am working on exporting filtered table data from Access to an Excel sheet, yet I can only get the table data to export into new Excel files and not into template Excel files (with pre-made graphs to be populated).
I mainly have been using macros on Access to create a switchboard where the user presses a switchboard-button and the filtered data exports from a table in Access to a new Excel file in a Reports folder. I do not know that macros are able to export with template Excel files, so I have turned to learning VBA. I am new to VBA so I apologize for my trivial understanding. I have created some VBA code based off of a tutorial from Access Jujitsu on Youtube.
Private Sub Command0_Click()
On Error GoTo SubError
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim SQL As String
Dim rs1 As DAO.Recordset
Dim i As Integer
Dim qtr As String
'Show user work is being performed
DoCmd.Hourglass (True)
'*********************************************
' RETRIEVE DATA
'*********************************************
'SQL statement to retrieve data from database
SQL = "SELECT Obj, Owner, Recom, Goal, Quality of Measure" & _
"FROM Inventory " & _
"WHERE Owner = ASM" &
"ORDER BY Recom "
'Execute query and populate recordset
Set rs1 = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)
'If no data, don't bother opening Excel, just quit
If rs1.RecordCount = 0 Then
MsgBox "No data selected for export", vbInformation + vbOKOnly, "No data exported"
GoTo SubExit
End If
'*********************************************
' BUILD SPREADSHEET
'*********************************************
'Create an instance of Excel and start building a spreadsheet
'Early Binding
Set xlApp = Excel.Application
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Open("\Users\Desktop to TemplateACC.xlsx")
Set xlSheet = xlBook.Worksheets(1)
With xlSheet
'Set second page title - pull quarter and year off of first row
'Won't work if you are pulling multiple time periods!
Select Case Nz(rs1!SalesQuarter, "")
Case 1
qtr = "1st"
Case 2
qtr = "2nd"
Case 3
qtr = "3rd"
Case 4
qtr = "4th"
Case Else
qtr = "???"
End Select
.Range("B3").Value = qtr & " Quarter " & Nz(rs1!SalesYear, "????")
'provide initial value to row counter
i = 1
'Loop through recordset and copy data from recordset to sheet
Do While Not rs1.EOF
.Range("I" & i).Value = Nz(rs1!Owner, "")
.Range("J" & i).Value = Nz(rs1!Goal, 0)
.Range("K" & i).Value = Nz(rs1!Recom, 0)
i = i + 1
rs1.MoveNext
Loop
End With
SubExit:
On Error Resume Next
DoCmd.Hourglass False
xlApp.Visible = True
rs1.Close
Set rs1 = Nothing
Exit Sub
SubError:
MsgBox "Error Number: " & Err.Number & "= " & Err.Description, vbCritical + vbOKOnly, _
"An error occurred"
GoTo SubExit
End Sub
Private Sub Form_Load()
End Sub
My code will not run as it says the "User-defined type is not defined" upon error. I have built this code from a button on a new form, opening the VBA coding template by building the event from the button. I am not sure why the code will not run. It is supposed to export to a pre-existing file called "TemplateACC" but instead this error appears. Thank you for sticking with me on this!
Have you added the Excel object library?
In the VBA editor go to Tools -> References, find Microsoft Excel 1X.0 Object Library and check it.
X depends on the version of Excel installed, but there should only be one, probably 14 to 16.
Binding may be your issue. You can implement early binding by adding the MS Excel Object Library to your References (Tools --> References), or you can implement late binding like below:
Private Sub Command0_Click()
Dim xlApp As object
Dim xlBook As object
Dim xlSheet As object
''If excel is already Running, grab that instance of the program, if not, create new
set xlApp = GetExcel
set xlBook = xlApp.Workbooks.Open("\Users\Desktop to TemplateACC.xlsx")
Set xlSheet = xlBook.Worksheets(1)
''... do other stuff
End sub
Function GetExcel() As Object 'Excel.Application
'Updated: 2009-10-13
'Used to grab the Excel application for automation
If DetectExcel Then
Set GetExcel = GetObject(, "Excel.Application")
Else
Set GetExcel = CreateObject("Excel.Application")
End If
End Function
Function DetectExcel() As Boolean
' Procedure dectects a running Excel and registers it.
Const WM_USER = 1024
Dim hwnd As Long
''If Excel is running this API call returns its handle.
hwnd = FindWindow("XLMAIN", 0)
If hwnd = 0 Then ' 0 means Excel not running.
DetectExcel = False
Exit Function
''Excel is running so use the SendMessage API
''function to enter it in the Running Object Table.
DetectExcel = True
SendMessage hwnd, WM_USER + 18, 0, 0
End If
End Function

Saving a worksheet into a new workboook but using values instead of the referencing formulas

So I am trying to create a workbook that uses multiple references from a worksheet of the initial data to auto fill cells in different worksheets to produce Forms (pre-formated worksheets). For one of the worksheets, I need to save it on a separate network drive as its own .xlsx workbook. So far, the code I have developed creates the new workbook, but the cells all still contain the original formulas that reference the original workbook. Is there a way, when saving into the new workbook, to convert the cells to values? Here is the sub I have in place. TIA
Private Sub SaveBidTab1_Click()
' Saves the BidTab in the Current Year's Bid Tabs Folder in
' Dave's Snapserver Construction Files
Dim BTFName As String 'this will be the name of the new file name saved in the Bid Tabs Folder
Dim BTFfolder As String 'This is the folder to save the form into
Dim BTFDate As String 'This is the date to choose which year's folder to use
Dim ProjectShortName As String 'This is the short name for the project for the file name
Dim NewBook As Workbook ' This is temp workbook that the new bid tab sheet will be saved as
If Worksheets("BidTab").Range("G12") = "" Then
ans = MsgBox("This form is not ready to be saved", vbOKOnly, "Bid Tabs")
Select Case ans
Case vbOK
Exit Sub
End Select
End If
'Requests user to enter in short name for project
Msg = "Enter Project Short Name"
ProjectShortName = InputBox(Msg, "Save As")
' TRIAL is added here until project is compelted.
BTFName = "TRIAL " & Worksheets("Initial Entry").Range("B5") & " " & ProjectShortName & _
" " & "Bid Tab Results" & " " & Worksheets("BidTab").Range("L5")
' Add in a cancle option to this msgbox
MsgBox BTFName
BTFDate = Year(Now())
BTFfolder = "M:\DotserverD\Daves Snapserver Files Construction Files\Bid Tabs\" & BTFDate _
& "\County"
Debug.Print BTFfolder
Set NewBook = Workbooks.Add
ThisWorkbook.Worksheets("BidTab").Copy Before:=NewBook.Sheets(1)
NewBook.SaveAs Filename:=BTFfolder & "\" & BTFName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
End Sub
ThisWorkbook.Worksheets("BidTab").Copy Before:=NewBook.Sheets(1)
Put this after the above statement:
With NewBook.Sheets(1).UsedRange
.Value = .Value
End With
This will remove the links and keep only the values in the new worksheet.
I have this in a similar book. You can probably simplify it.
Dim shShape As Shape
For i = 1 To UBound(sheetNames)
mSaveWorkbook.Sheets(i).Name = sheetNames(i)
If mSaveWorkbook.Sheets(i).Shapes.Count > 0 Then
For Each shShape In mSaveWorkbook.Sheets(i).Shapes
If shShape.Type = msoFormControl Then
shShape.Delete
End If
Next shShape
End If
Next i
End If

Replacing an InputBox with a Userform (combobox)?

Forgive my noob-ery. Assistance greatly appreciated!!!!
Purpose of macro: Fill in form in Microsoft Word with text originating in an Excel workbook from a specified worksheet.
My problem: Selecting said worksheet to draw that information from and integrating result into my code. Using an InputBox for now but would like to replace said InputBox with a UserForm with a ComboBox- giving pre-set choice for worksheet names (these never change).
I've created the UserForm with the choices. How do I get my code to initialize it? And how do I get my code to use the result from the ComboBox?
Sub Ooopsie()
Dim objExcel As New Excel.Application
Dim exWb As Excel.Workbook
Dim exSh As Excel.Worksheet
Dim strSheetName As String
Dim strDefaultText As String
strDefaultText = "sheet name here"
strSheetName = InputBox( _
Prompt:="The sheet name is?", _
Title:="Sheet Name?", _
Default:=strDefaultText _
)
If strSheetName = strDefaultText Or strSheetName = vbNullString Then Exit Sub
Set exWb = objExcel.Workbooks.Open("path to worksheet")
ActiveDocument.Tables(1).Rows(3).Cells(1).Range.Text = "Blah: " & exWb.Sheets(strSheetName).Cells(3, 3)
ActiveDocument.Tables(1).Rows(5).Cells(1).Range.Text = "blah blah : " & Chr(11) & "blah: " & exWb.Sheets(strSheetName).Cells(3, 1)
ActiveDocument.Tables(1).Rows(6).Cells(1).Range.Text = "Date de réception : " & Chr(11) & "Date Received : " & exWb.Sheets(strSheetName).Cells(3, 2)
ActiveDocument.Tables(1).Rows(7).Cells(1).Range.Text = "blah d : " & Chr(11) & "Deadline: " & exWb.Sheets(strSheetName).Cells(3, 4)
exWb.Close
Set exWb = Nothing
End Sub
I refined your code some. This should get you started. I reworked it to make it easier for you to see what's going on. Instead of opening an existing workbook I create a new workbook. I left the Inputbox in there with some error handling so you get an idea of what you should do. The code now right from the MS Word table to Excel.
Option Explicit
Private Sub CommandButton1_Click()
Dim xlApp, xlWB, xlWS
Dim strSheetName As String, strDefaultText As String
Dim tbl As Table
strDefaultText = "Sheet1"
strSheetName = InputBox( _
Prompt:="The sheet name is?", _
Title:="Sheet Name?", _
Default:=strDefaultText)
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Add
On Error Resume Next
Set xlWS = xlWB.WorkSheets(strSheetName)
If Err.Number <> 0 Then
MsgBox "Worksheet [" & strSheetName & " Not Found", vbCritical, "Action Cancelled"
xlWB.Close False
xlApp.Quit
Exit Sub
End If
On Error GoTo 0
xlApp.Visible = True
On Error Resume Next
If ActiveDocument.Tables.Count > 0 Then
Set tbl = ActiveDocument.Tables(1)
xlWS.Cells(3, 3) = tbl.Rows(3).Cells(1).Range.Text
xlWS.Cells(3, 1) = tbl.Rows(5).Cells(1).Range.Text
xlWS.Cells(3, 2) = tbl.Rows(6).Cells(1).Range.Text
xlWS.Cells(3, 4) = tbl.Rows(7).Cells(1).Range.Text
End If
Set xlWB = Nothing
Set xlApp = Nothing
End Sub
It is worth noting that you can't instantiate Excel from MS Word like this without a reference to the Microsoft Excel 12.0 I think is?
Dim objExcel As New Excel.Application
Use this instead
Dim objExcel as Variant
Set objExcel = CreateObject("Excel.Application")
I know that this is not a chat forum but I am open to opinions and advice. I am only a hobbist after all.
Update here is how one way add items to a combobox
For Each xlSheet In xlWB.Worksheets
ComboBox1.AddItem xlSheet.Name
Next
So you've created a form called UserForm1.
You can display it as a modal dialog using the default instance:
UserForm1.Show vbModal
But a better practice would be to instantiate it instead - forms are objects after all, so you can New them up like any other class module:
Dim view As UserForm1
Set view = New UserForm1
view.Show vbModal
You can add properties to your form's code-behind to expose values the calling code can use:
Public Property Get SheetName() As String
SheetName = ComboBox1.Text
End Property
So you can now write a function that does this:
Private Function GetSheetName() As String
Dim view As UserForm1
Set view = New UserForm1
view.Show vbModal
GetSheetName = view.SheetName
End Function
Now you can replace your InputBox call with a call to this GetSheetName function!
Of course you'll want to handle the case where the user cancels out of the form, but that's beyond the scope of this question, and... it's been asked on this site already, just search and you'll find!

how to copy values from the same named ranges from one workbook to another

I have an extensive Workbook which exists in multiple versions that contains hundreds of named ranges.
I want to write a macro that transfers user input data entered to certain named ranges from one instance of the book to another.
The named ranges in the book follow a certain convention, for the purposes of this macro i want to copy the values (which are constants) of all named ranges starting with "in_*" and "resetRange_*"
the macro is supposed to:
open the source book (which has mostly the same named ranges defined as the current book)
iterate over all named ranges of the source book and find the ones like "in_*" or "resetRange_*"
copy the values at the named ranges from the source book to the current book (even if the names refer to areas)
my main questions are:
how do i copy correctly? the current implementation does not work
is there a better way to test whether a source name is still present in the current book?
the named ranges in question all are scoped to the workbook.
The issue that the macro runs error free but does not paste any values. the named ranges of the current book remain empty while the source book contains data
´
Public Sub TransferInputDataFromOtherTool()
Dim sourceBook As Workbook
Dim bookPath As Variant
'get source book
bookPath = Application.GetOpenFilename("(*.xlsm), *.xlsm", Title:="Select source tool:")
If VarType(bookPath) = vbString Then
Set sourceBook = Workbooks.Open(bookPath)
End If
On Error GoTo Cleanup
'#TODO transfer ranges _
resetRange_* _
in_*
'retrieving data
For Each n In sourceBook.Names
On Error Resume Next
rangeName = n.Name
boola = ThisWorkbook.Names(n.Name)
If boola Then
On Error GoTo 0
If rangeName Like "in_*" _
or rangeName like "resetRange_*" Then
'check for allow edit
On Error Resume Next
sourceBook.Activate
source_value = n.refersToRange.Value
ThisWorkbook.Activate
Range(rangeName).Value = source_value
'Debug.Print rangeName, source_value
'Debug.Print Err.Description, Err.source
On Error GoTo 0
End If
' deleting all in_-values
End If
Next n
'#TODO transfer tables
'ExcelHandling.EnableInteractivity
Cleanup:
On Error Resume Next
sourceBook.Close
On Error GoTo 0
End Sub
Here's a code sample to help. Please turn on Option Explicit and define all your VBA variables. See if this works for you:
EDIT: added range check to detect more than one cell in a given range, then to copy each cell
Option Explicit
Sub TransferInputDataFromOtherTool()
Dim srcWB As Workbook
Dim destWB As Workbook
Dim filename As String
Dim definedVariable As Name
Dim singleCell As Range
Dim singleCellLocation As String
'--- the destination book is the currently active workbook from the user's perspective
Set destWB = ThisWorkbook
'--- source book from which to copy the data from - user selected
filename = Application.GetOpenFilename("(*.xlsm), *.xlsm", Title:="Select source tool:")
If filename = "False" Then
'--- the user selected cancel
Exit Sub
ElseIf filename = destWB.Path & "\" & destWB.Name Then
MsgBox "You can't open the same file that's already active. Select another file.", vbCritical + vbOKOnly
Exit Sub
Else
Set srcWB = Workbooks.Open(filename)
End If
Debug.Print "values coming from " & filename
For Each definedVariable In srcWB.Names
If (definedVariable.Name Like "in_*") Or (definedVariable.Name Like "resetRange_*") Then
'--- if the source/destination range is only a single cell, then
' it's an easy one-to-one copy
Debug.Print definedVariable.Name & " refers to " & definedVariable.RefersTo;
If destWB.Names(definedVariable.Name).RefersToRange.Cells.Count = 0 Then
'--- do nothing
ElseIf destWB.Names(definedVariable.Name).RefersToRange.Cells.Count = 1 Then
Debug.Print " source value = '" & destWB.Names(definedVariable.Name).RefersToRange.Value & "'";
Debug.Print " overwritten with '" & srcWB.Names(definedVariable.Name).RefersToRange.Value & "'"
destWB.Names(definedVariable.Name).RefersToRange = srcWB.Names(definedVariable.Name).RefersToRange.Value
Else
'--- the source/target range has multiple cells, either contiguous
' or non-contiguous. so loop and copy...
Debug.Print vbTab & "multiple cells in range..."
For Each singleCell In destWB.Names(definedVariable.Name).RefersToRange
singleCellLocation = "'" & singleCell.Parent.Name & "'!" & singleCell.Address
Debug.Print vbTab & " source value = '" & singleCell.Value & "'";
Debug.Print "' overwritten with '" & srcWB.Sheets(singleCell.Parent.Name).Range(singleCell.Address).Value & "'"
singleCell.Value = srcWB.Sheets(singleCell.Parent.Name).Range(singleCell.Address).Value
Next singleCell
End If
End If
Next definedVariable
srcWB.Close SaveChanges:=False
Set srcWB = Nothing
Set destWB = Nothing
End Sub

VBA Access 2010 - prompt user to pick a file and dim the filename as variable

my Access database exports a report in xls, that needs to be further reworked (some manual adjustments of columns etc. + vlookuping some comments from report from previous day).
Here is the part of the code I created so far:
Option Compare Database
Function Adjustment()
' First I want to prompt user to select the report from previous day*
Dim f As Object
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
MsgBox (strFile)
Next
End If
Set f = Nothing
' here my Access database opens current report that has been exported
Dim xl As Object
Set xl = CreateObject("Excel.Application")
xl.Workbooks.Open ("I:\Temp\reports.xlsx")
xl.Visible = True
' in currently open report, I want fill cell I2 and J2 with VLOOKUP function referencing to previously selected file
Range("I2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]SheetXY'!C7:C12,3,0)"
Range("J2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]SheetXY!C7:C12,4,0)"
End function
Problem: I am being prompted every every time to select the file, when formula is being filled in I2 and J2, so how can I disable this and keep Access to reference strFile only once?
Question: So far, every first sheet in the refrenced workbook is called SheeyXY, but what if I would like to reference also a different Sheets (let`s say always the first sheet in the workbook no matter what its name is).
Maybe you can try this ..
Option Compare Database
Function Adjustment(SheetName as String) '---> add parameter such as "SheetXY"
' First I want to prompt user to select the report from previous day*
Dim f As Object
Dim strFolder As String
Dim varItem As Variant
Static strFile As String
If strFile = "" Then
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
MsgBox (strFile)
Next
End If
Set f = Nothing
Endif
' here my Access database opens current report that has been exported
Dim xl As Object
Set xl = CreateObject("Excel.Application")
xl.Workbooks.Open ("I:\Temp\reports.xlsx")
xl.Visible = True
' in currently open report, I want fill cell I2 and J2 with VLOOKUP function referencing to previously selected file
Range("I2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]" & SheetName & "'!C7:C12,3,0)"
Range("J2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]" & SheetName & "'!C7:C12,4,0)"
End function
Have you tried taking out the .FormularR1C1 from those lines?
Also, I'm not sure exactly what you're trying to do with the sheet names, but you could probably hack something together from this?
Debug.Print Worksheets(1).Name
or
For Each ws In Worksheets
Debug.Print ws.Name
Next
UPDATE:
Try this, and report back?
With xl.Worksheets(1)
.Range("I2").FormulaR1C1 = "=VLOOKUP(RC7,[" & strFile & "]Sheet1!C7:C12,3,0)"
.Range("J2").FormulaR1C1 = "=VLOOKUP(RC7,[" & strFile & "]Sheet1!C7:C12,4,0)"
End With
So with the extra clarification of which range, and without the extra apostrophe