VBA替代Vlookup实现同名称多值拼接跨工作表取数咨询

实现方案 #

核心思路 #

• 放弃VLookup实现，改用直接遍历查询范围的方式匹配所有符合条件的条目，将匹配结果按要求用/拼接后输出
• 修正原代码中变量赋值顺序错误：原代码先取Ip.Cells(2, 6)的值再给Ip对象赋值，会导致取值错误，调整为先赋值Ip对象再读取BottleSKU

修改后完整代码 #

Sub Packaging_run_dropbox_change(ColRef As Integer)
On Error Resume Next

'Created by Marc Hipolito on 26/10/2021
'修改：支持多匹配结果拼接

'# This subroutine is a slave routine used by all
'# Packaging run dropbox routines

'# Variables
Dim BP As Worksheet         '# Bottling Programme
Dim Ip As Worksheet         '# Input worksheet
Dim Ref As Worksheet        '# Ref worksheet
Dim ptr As Integer          '# Pointer
Dim BottleSKU As String     '# Bottle SKU（建议改为String适配文本格式的SKU）
Dim BPBottleType As String  '# Comment from bottling programme
Dim i As Integer            '# pointer
Dim skuRes As String, matRes As String '# 存储拼接后的结果

'# Set worksheet objects
Set BP = Worksheets("Bottling Programme")
Set Ref = Worksheets("Ref")
Set Ip = Worksheets("DepalBottles") '调整赋值顺序，先给Ip赋值再取值

'# Use dropdown box selection number as pointer
ptr = Ref.Range("L" & ColRef + 1)

'# Find Bottle SKU according to Bottle Type
BottleSKU = Ip.Cells(2, 6)

'# 遍历匹配所有符合条件的结果
skuRes = ""
matRes = ""
For i = 2 To 20 '如果范围不固定可以改为 Ref.Cells(Ref.Rows.Count, "A").End(xlUp).Row
    If Ref.Cells(i, "A") = BottleSKU Then
        skuRes = skuRes & "/" & Ref.Cells(i, "C")
        matRes = matRes & "/" & Ref.Cells(i, "B")
    End If
Next i

'# 去掉开头多余的/分隔符后赋值
If Len(skuRes) > 0 Then
    Ip.Range("C2") = Mid(skuRes, 2)
    Ip.Range("D2") = Mid(matRes, 2)
Else
    '无匹配结果时的赋值逻辑，可按需修改
    Ip.Range("C2") = ""
    Ip.Range("D2") = ""
End If

End Sub

优化说明 #

如果你的Excel版本是365/2021及以上，也可以直接用工作表公式实现，不用改VBA逻辑：

• C2单元格公式：=TEXTJOIN("/",TRUE,IF(Ref!A2:A20=F2,Ref!C2:C20,"")) 按Ctrl+Shift+Enter回车（数组公式）
• D2单元格公式：=TEXTJOIN("/",TRUE,IF(Ref!A2:A20=F2,Ref!B2:B20,"")) 按Ctrl+Shift+Enter回车

如果查询范围经常变动，可以把代码中固定的循环上限20改为动态取值：Ref.Cells(Ref.Rows.Count, "A").End(xlUp).Row，无需手动调整范围。

内容的提问来源于stack exchange，提问作者Marc Hipolito