I am trying to create a macro for a cell(B5) which can contain 5 different words:
For every word I want to activate a different Vlookup
and show the (Integer) result in (B10)
I also want to run the Macro after typing the word in cell B5 and pressing enter, so no buttons.
I am not used to using VBA:
Sub Rate()
Dim text As String
Range("B5").Value = text
Dim Rate As Integer
Range("B10").Value = Rate
If text = "BRUBRU" Then
Rate = Application.WorksheetFunction.VLookup(B12,[RATES.xlsx]Sheet1!$A$4:$F$461,2,FALSE)
Else
If text = "BRUEUR" Then
Rate = Application.WorksheetFunction.VLookup(B12,[RATES.xlsx]Sheet1!$A$4:$F$461,3,FALSE)
Else
If text = "BRUBRI" Then
Rate = Application.WorksheetFunction.VLookup(B12,[RATES.xlsx]Sheet1!$A$4:$F$461,4,FALSE)
Else
If text = "BRUSTA" Then
Rate = Application.WorksheetFunction.VLookup(B12,[RATES.xlsx]Sheet1!$A$4:$F$461,5,FALSE)
Else
If text = "BRUAIR" Then
Rate = Application.WorksheetFunction.VLookup(B12,[RATES.xlsx]Sheet1!$A$4:$F$461,6,FALSE)
Else
End If
End Sub
Could anyone help me with this?
Ty!
David
I have had a look at the code that you have give me and This is what i have turned out for you.
Instead of using loads of IF statements, i have used a Select Case statement which makes things a bit easier/and cleaner.
With VBA you need to specify the variable and then what the value contains (eg X = 10, not 10 = X) and some variables need to be set, (eg Ranges, Workbooks and Sheets)
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B5")) Is Nothing Then Rate
End Sub
Sub Rate()
Dim text As String
Dim Rate As Range
text = Range("B5").Value
Set Rate = Range("B10")
Select Case text
Case "BRUBRU"
Rate.Formula = "=vlookup(B12,DataStore!$A$4:$F$461,2,FALSE)"
Case "BRUEUR"
Rate.Formula = "=VLookup(B12,DataStore!$A$4:$F$461,3,FALSE)"
Case "BRUBRI"
Rate.Formula = "=VLookup(B12,DataStore!$A$4:$F$461,4,FALSE)"
Case "BRUSTA"
Rate.Formula = "=VLookup(B12,DataStore!$A$4:$F$461,5,FALSE)"
Case "BRUAIR"
Rate.Formula = "=VLookup(B12,DataStore!$A$4:$F$461,6,FALSE)"
End Select
End Sub
You could have your code copy the information in your Rates.xlsx to a hidden worksheet when the workbook opens which doesn't prolong the opening time of the document.
I would love to claim this work as my own but I have done a bit of googling and found a solution that should work. This is the website which has helped me with your problem. http://www.rondebruin.nl/
I have changed the code above to work with the new sheet so your code will need some updating for this to work.
This code is when you open the file and goes in ThisWorkbook:
Private Sub Workbook_Open()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant
Dim SDataWS As Worksheet
SaveDriveDir = CurDir
MyPath = Application.ActiveWorkbook.Path ' "C:\Data" or use Application.DefaultFilePath - Takes you to your defult save folder
ChDrive MyPath
ChDir MyPath
FName = Application.ActiveWorkbook.Path & "\RATES.xlsx"
'If your file which has the data in is in the same folder, this shouldn't need adjusting
'Alternatively you could search for the file each time by using - Application.GetOpenFilename(filefilter:="Excel Files, *.xl*")
If FName = False Then
'do nothing
Else
On Error Resume Next
Set SDataWS = Sheets("DataStore")
If SDataWS Is Nothing Then
Sheets.Add.Name = "DataStore"
With Sheets("DataStore")
.Visible = False
End With
End If
On Error GoTo 0
GetData FName, "Sheet1", "A1:F461", Sheets("DataStore").Range("A1"), False, False
End If
End Sub
This part goes into your module:
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long
' Create the connection string.
If Header = False Then
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
End If
Else
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes"";"
End If
End If
If SourceSheet = "" Then
' workbook level name
szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
' worksheet level name or range
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If
On Error GoTo SomethingWrong
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1
' Check to make sure we received data and copy the data
If Not rsData.EOF Then
If Header = False Then
TargetRange.Cells(1, 1).CopyFromRecordset rsData
Else
'Add the header cell in each column if the last argument is True
If UseHeaderRow Then
For lCount = 0 To rsData.Fields.Count - 1
TargetRange.Cells(1, 1 + lCount).Value = _
rsData.Fields(lCount).Name
Next lCount
TargetRange.Cells(2, 1).CopyFromRecordset rsData
Else
TargetRange.Cells(1, 1).CopyFromRecordset rsData
End If
End If
Else
MsgBox "No records returned from : " & SourceFile, vbCritical
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub
SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0
End Sub
Hope this helps!
Craig
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.