使用Vlookup函数在Excel中创建宏

Question

I am trying to create a macro for a cell(B5) which can contain 5 different words:

1. BRUBRU
2. BRUEUR
3. BRUBRI
4. BRUSTA
5. BRUAIR

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

Answer 1

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