VLookup 与匹配
- 两种解决方案都会写入值（而不是公式），因为您在 cmets 中写了 “我最初希望它在 VBA 中计算，但我无法计算出来！”。
快速修复（不推荐）
Option Explicit
Sub Worksheet_Caps()
Dim SrchRng As Range: Set SrchRng = Range("G21:G27")
Dim LkpRng As Range: Set LkpRng = Worksheets("Data").Range("P2:Q110")
Dim SrchCell As Range
Dim MatchValue As Variant
For Each SrchCell In SrchRng.Cells
If Len(CStr(SrchCell.Value)) > 0 Then
MatchValue = Application.VLookup(SrchCell.Value, LkpRng, 2, False)
If Not IsError(MatchValue) Then
SrchCell.Offset(, -1).Value = MatchValue
'Else
'SrchCell.Offset(, -1).Value = Empty
End If
End If
Next SrchCell
End Sub
改进
- 以下使用更灵活的
Application.Match 代替VLookup 的任何“风味”。
- 调整（使用）常量部分中的值。
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Performs a 'VLookup' using 'Application.Match'.
' Remarks: Uses the 'RefColumn' and 'GetRange' functions.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub WorksheetCaps()
On Error GoTo ClearError
' Source
Const sName As String = "Data" ' Worksheet Name
Const slFirst As String = "P2" ' First Lookup Cell Address
Const svCol As String = "Q" ' Value Column
' Destination
Const dName As String = "Sheet1" ' Worksheet Name
Const dlFirst As String = "G21" ' First Lookup Cell Address
Const dvCol As String = "F" ' Value Column
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the Source Lookup Range ('slrg').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slfCell As Range: Set slfCell = sws.Range(slFirst)
Dim slrg As Range: Set slrg = RefColumn(slfCell)
If slrg Is Nothing Then Exit Sub ' no data in source
' You can always use a static range instead of the previous 3 lines:
'Dim slrg As Range: Set slrg = sws.Range("P2:P110")
' Create a reference to the Destination Lookup Range ('dlrg').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dlfCell As Range: Set dlfCell = dws.Range(dlFirst)
Dim dlrg As Range: Set dlrg = RefColumn(dlfCell)
If dlrg Is Nothing Then Exit Sub ' no data in destination
' You can always use a static range instead of the previous 3 lines:
'Dim dlrg As Range: Set dlrg = dws.Range("G21:G27")
' Create a reference to the Source Value Range ('svrg').
Dim svrg As Range: Set svrg = slrg.EntireRow.Columns(svCol)
' Write the values from the Source Value Range
' to the Source Value Array ('svData').
Dim svData As Variant: svData = GetRange(svrg)
' Write the values from the Destination Lookup Range
' to the Destination Array ('dData').
Dim dData As Variant: dData = GetRange(dlrg)
' Declare additional variables.
Dim smrIndex As Variant ' Source Match Row Index
Dim dlValue As Variant ' Destination Lookup Value
Dim dr As Long ' Destination Row Counter
' Loop through the elements (rows) of the Destination Array.
For dr = 1 To UBound(dData, 1)
' Write the (lookup) value of the current element
' in the Destination Array to a variable ('dlValue').
dlValue = dData(dr, 1)
' Replace the (lookup) value of the current element
' in the Destination Array with 'Empty'.
dData(dr, 1) = Empty
If Not IsError(dlValue) Then ' not an error value
If Len(dlValue) > 0 Then ' not a blank
' Attempt to find a match of the current
' Destination Lookup value in the Source Lookup Range.
smrIndex = Application.Match(dlValue, slrg, 0)
If IsNumeric(smrIndex) Then ' a match (the first occurrence)
' Write the corresponding value (in the same row)
' of the Source Lookup Range in the Source Value Array
' to the current element in the Destination Array.
dData(dr, 1) = svData(smrIndex, 1)
'Else ' not a match (resulting in an error value)
End If
' Else ' a blank: Empty, ="", ',...
End If
' Else ' any error value
End If
Next dr
' Create a reference to the Destination Value Range ('dvrg').
Dim dvrg As Range: Set dvrg = dlrg.EntireRow.Columns(dvCol)
' Write the (modified) values from the Destination Array
' to the Destination Value Range (in one go).
dvrg.Value = dData
' Save the workbook.
wb.Save
' Inform the user.
MsgBox "The lookup has finished successfully.", _
vbInformation, "Worksheet Caps"
ProcExit:
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
End Function