VBA新手求助：自定义类VLOOKUP函数无法批量粘贴匹配结果

核心问题 #

Excel用户自定义函数（UDF）默认仅允许返回值到调用单元格，不能直接修改其他单元格。你之前用Evaluate调用子过程的方式仅处理了单个值，未实现数组批量写入。

方案一：改用子过程（推荐） #

子过程不受UDF的限制，可自由操作单元格，是更稳妥的实现方式：

Option Explicit
Option Compare Text

Sub PROCTUDO_Sub(x As Variant, mProc As Range, mResult As Range, mOut As Range)
    Dim mValores() As Variant
    Dim total As Long, i As Long
    Dim j As Long
    
    total = WorksheetFunction.CountIf(mProc, x)
    
    ' 无匹配结果时清空输出区域
    If total = 0 Then
        mOut.Resize(mOut.CurrentRegion.Rows.Count).ClearContents
        Exit Sub
    End If
    
    ReDim mValores(1 To total, 1 To 1) As Variant
    j = 1
    For i = 1 To mProc.Cells.Count
        If mProc.Cells(i).Value = x Then
            mValores(j, 1) = mResult.Cells(i).Value
            j = j + 1
        End If
    Next
    
    ' 清空旧数据并写入新数组
    mOut.Resize(mOut.CurrentRegion.Rows.Count).ClearContents
    mOut.Resize(total).Value = mValores
End Sub

使用方式：
可通过宏窗口调用，或给工作表按钮绑定该子过程，示例调用代码：

PROCTUDO_Sub "目标值", Range("A:A"), Range("B:B"), Range("D1")

方案二：改进原UDF（不推荐，仅作技术参考） #

若坚持用UDF实现，需调整Evaluate调用逻辑，传递整个数组给子过程，但需注意UDF修改其他单元格可能引发计算异常：

Option Explicit
Option Compare Text
    
Function PROCTUDO(x, mProc As Range, mResult As Range, mOut As Range) As Variant
    Dim mValores() As Variant
    Dim total As Long, i As Long
    Dim j As Long
    
    total = WorksheetFunction.CountIf(mProc, x)
    
    ReDim mValores(1 To total + 1, 1 To 1) As Variant
    mValores(1, 1) = total
    j = 2
    For i = 1 To mProc.Cells.Count
        If mProc.Cells(i).Value = x Then
            mValores(j, 1) = mResult.Cells(i).Value
            j = j + 1
        End If
    Next
    
    ' 调用子过程批量写入数组
    mOut.Parent.Evaluate "WriteArray(" & mOut.Address(False, False) & "," & GetArrayAddress(mValores) & ")"
    
    PROCTUDO = mValores
End Function

Sub WriteArray(alvo As Range, arr As Variant)
    ' 清空输出区域旧数据并写入数组
    alvo.Resize(UBound(arr)).ClearContents
    alvo.Resize(UBound(arr)).Value = arr
End Sub

Function GetArrayAddress(arr As Variant) As String
    ' 将数组转为Excel公式可识别的字符串格式
    Dim i As Long
    Dim strArr As String
    
    strArr = "{"
    For i = 2 To UBound(arr) ' 跳过总数，仅取匹配结果
        strArr = strArr & """" & arr(i, 1) & """" & ","
    Next
    If Len(strArr) > 1 Then strArr = Left(strArr, Len(strArr) - 1)
    strArr = strArr & "}"
    
    GetArrayAddress = strArr
End Function

注意事项：

• UDF修改其他单元格违背Excel的设计逻辑，可能在自动计算时出现重复写入、计算延迟等问题。
• 工作表中调用UDF时（如=PROCTUDO(A1,B:B,C:C,D1)），每次Excel重新计算都会触发写入操作。

内容的提问来源于stack exchange，提问作者Lucas Rosa