Question

我有一个基本的UDF，它基本上连接了vlookup的多个匹配

            Function MYVLOOKUP(lookupval, lookuprange As Range, indexcol1 As Long, indexcol2 As Long, indexcol3 As Long)
            'disable slow apps
            Application.ScreenUpdating = False
            Application.DisplayStatusBar = False
            Application.EnableEvents = False
            ActiveSheet.DisplayPageBreaks = False

            'main code
            Dim r As Range
            Dim result As String
            'set string to null instead of nothing
            result = vbNullString
            For Each r In lookuprange
                If r = lookupval Then
                    result = result & " " & r.Offset(0, indexcol1 - 1) & " " & r.Offset(0, indexcol2 - 1) & " " & r.Offset(0, indexcol3 - 1) & "|"
                End If
            Next r
            'output results
            MYVLOOKUP = result

            'enable apps
            Application.ScreenUpdating = True
            Application.DisplayStatusBar = True
            Application.EnableEvents = True
            ActiveSheet.DisplayPageBreaks = True

            'end function
            End Function

有没有办法加快速度，我的老板不想在电子表格中添加任何新的数据或列，因此它必须是这个功能。但是在超过320000个单元上运行它需要很长时间。

感谢所有帮助。

更新：添加了一些加速代码，但仍然很慢

数据以这种方式格式化

     Sheet 1
    1 |   |
    2 |   |
    3 |   |
    4 |   |
    5 |   |
    6 |   |
    7 |   |
    Sheet 2
    1   |1a     |b      |c
    1   |1ab    |bb     |cc
    1   |1abc   |bbb    |cccc
    1   |abcd   |bbbb   |cccc
    2   |a      |b      |c
    2   |ab     |bb     |cc
    2   |abc    |bbb    |cccc
    2   |abcd   |bbbb   |cccc
    3   |a      |b      |c
    3   |ab     |bb     |cc
    4   |a      |b      |c
    5   |a      |b      |c
    6   |a      |b      |c
    7   |wer    |werr   |rewsfd

    i need it to look like this
    1 |1a b c| 1ab bb cc| 1abc bbb cccc| abcd bbbb cccc|

它必须能够处理20列

Answer 1

你正在运行它超过320000个细胞......你运行了多少次？它是一个计算列，你有320K公式，或者你只有10或20公式？请使用示例数据的屏幕截图更新您的答案，以及实际公式的示例，我将改进我的答案。

如果LookUpTable是单列或多列，则会有很大的不同。我LookUpTable是一列，然后不使用UDT。使用Match和Index的组合可能是您最好的选择。

您应该阅读：EXCEL VLOOKUP VS INDEX MATCH VS SQL VS VBA。

找到匹配后退出该功能将大大提高性能。

Function MYVLOOKUP(LookUpValue As String, LookUpTable As Range, Column1 As Long, Column2 As Long, Column3 As Long) As String
    Dim rng As Range
    Dim xResult As String
    xResult = ""
    For Each rng In LookUpTable
        If rng = LookUpValue Then
            MYVLOOKUP = xResult & " " & rng.Offset(0, Column1 - 1) & " " & rng.Offset(0, Column2 - 1) & " " & rng.Offset(0, Column3 - 1)
            Exit Function
        End If
    Next

End Function

Answer 2

这会在查找值之前将范围放入数组中。只要它们位于查找表的范围内，您就可以向返回添加任意数量的列。

我还没有在一个大记录集上测试它，但是阵列肯定会更快吗？

Public Function MYVLOOKUP(LookUpValue As String, LookUpTable As Range, ParamArray lColumn()) As Variant

    Dim vTable As Variant
    Dim x As Long, y As Long
    Dim lMaxCol As Long
    Dim sResult As Variant

    vTable = LookUpTable

    'Check a column outside the range of LookUpTable isn't being asked for.
    For x = LBound(lColumn) To UBound(lColumn)
        If lColumn(x) > lMaxCol Then
            lMaxCol = lColumn(x)
        End If
    Next x

    If lMaxCol <= LookUpTable.Columns.Count Then
        'Work through the array looking for the value, and return values from specified array elements.
        For x = LBound(vTable, 1) To UBound(vTable, 1)
            If vTable(x, 1) = LookUpValue Then
                For y = LBound(lColumn) To UBound(lColumn)
                    sResult = sResult & " " & vTable(x, lColumn(y))
                Next y
            End If
        Next x
    Else
        'Column outside the range is asked for - return a #REF error.
        sResult = CVErr(xlErrRef)
    End If

    MYVLOOKUP = sResult

End Function

修改：想知道我是否可以使用数组公式和Application.Caller

在一次点击中完成所有操作

Answer 3

您可以使用AutoFilter()方法：

Function MYVLOOKUP(LookUpValue As String, LookUpTable As Range, Column1 As Long, Column2 As Long, Column3 As Long) As String
    Dim rng As Range
    Dim refCol As Long
    Dim xResult As String

    With LookUpTable '<--| reference table
        refCol = .Columns(1).Column '<--| assume referenced table 1st column as column to offset "result" columns from
        .AutoFilter field:=1, Criteria1:=LookUpValue '<--| filter on referenced table 1st column with given 'LookUpValue '
        If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any cell filtered other than header (which is in first row)
            For Each rng In .Resize(.Rows.Count - 1, 1).Offset(1).SpecialCells(xlCellTypeConstants).SpecialCells(xlCellTypeVisible) '<--| loop through table 1st column filtered not empty cells after headers row
                xResult = xResult & " " & rng.Offset(0, Column1 - refCol) & " " & rng.Offset(0, Column2 - refCol) & " " & rng.Offset(0, Column3 - refCol)
            Next rng
        End If
        .Parent.AutoFilterMode = False
    End With
    MYVLOOKUP = xResult
End Function

假设：

LookUpTable可以是任何多列范围
LookUpTable第一行是＆＃34;标题＆＃34;
Column1，Column2，Column3是绝对列索引，可以抓取＆＃34;结果＆＃34;来自
的细胞
它们甚至可能位于LookUpTable列范围

Answer 4

马特，这是你在找什么？

Sub TableFromRelational()
Dim InArr: InArr = Selection.CurrentRegion.Value
Dim Coll As Scripting.Dictionary
Set Coll = New Scripting.Dictionary
Dim RsltArr
Dim I As Long
For I = LBound(InArr) To UBound(InArr)
Dim Key As Double: Key = InArr(I, LBound(InArr, 2))
If Coll.Exists(Key) Then
RsltArr = Coll(Key)
ReDim Preserve RsltArr(UBound(RsltArr) + 1)
Coll.Remove Key
Else
ReDim RsltArr(0)
End If
RsltArr(UBound(RsltArr)) = InArr(I, LBound(InArr, 2) + 1)
Coll.Add Key, RsltArr
Next I
Dim DestRng As Range
With Selection.CurrentRegion
Set DestRng = .Offset(0, .Columns.Count + 1).Cells(1, 1)
End With
DestRng.Resize(Coll.Count, 1).Value = Application.WorksheetFunction.Transpose(Coll.Keys)
For I = 0 To Coll.Count - 1
RsltArr = Coll(Coll.Keys(I))
DestRng.Offset(I, 1).Resize(1, UBound(RsltArr) + 1).Value = RsltArr
Next I
End Sub

加速Excel UDF

4 个答案: