在Excel中创建与VLOOKUP函数

Question

我试图创建一个细胞（B5）一个宏可以包含5个不同的字的宏：

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

对于每一个字，我想，以激活不同（B10）

我也想在单元格B5中键入单词并按下回车键后运行宏，因此没有按钮。

我不习惯用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 

谁能帮助我？

Ty！

大卫

Answer 1

我有看你有给我的代码，这是我原来的你。

而不是使用IF语句，我用Select Case语句，这使得事情变得更简单/和清洁负荷。

用VBA你需要指定变量，然后什么值包含（例如：X = 10，而不是10 = X）和一些变量需要进行设置，（如范围，工作簿和工作表）

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 

当打开工作簿不会延长文档的打开时间时，您可以让您的代码将您的Rates.xlsx中的信息复制到隐藏的工作表中。

我很想要求这项工作作为我自己，但我已经做了一些谷歌上搜索，发现应该工作的解决方案。这是帮助我解决问题的网站。 http://www.rondebruin.nl/

我已经改变了上面的代码与新工作表工作，使你的代码需要一些更新这个工作。

此代码是当你打开文件，就走了进去的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 

这部分进入你的模块：

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 

希望这有助于！

克雷格