Question

我正在尝试为一个单元格创建一个宏（B5），它可以包含5个不同的单词：

BRUBRU
BRUEUR
BRUBRI
BRUSTA
BRUAIR

对于我想要激活不同Vlookup的每个单词并在（B10）中显示（整数）结果

我还想在单元格B5中键入单词并按Enter后运行宏，所以没有按钮。

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

有人可以帮我吗？

泰！

大卫

Answer 1

我看过你给我的代码，这就是我为你所做的。

我使用了Select Case语句，而不是使用IF语句的加载，这使得事情变得更容易/更清晰。

使用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

希望这有帮助！

克雷格

使用Vlookup功能在Excel中创建宏

1 个答案: