Question

此功能的当前性能较慢，目前我正在处理sheet1上的500多个商品代码列表。该函数在sheet2的200 000多个项目中进行搜索，以找到所有匹配项，包括部分匹配项。这意味着我们在查找条件之前和之后都包含一个通配符，以查找所有匹配项。

当前需要15分钟才能完成。有更好的方法吗？要在5分钟之内得到这个？

Function ConcatIf(ByVal compareRange As Range, ByVal xCriteria As Variant, _
                        Optional ByVal stringsRange As Range, Optional Delimiter As String) As String

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False

    Dim i As Long, j As Long, criteriaMet As Boolean

    Set compareRange = Application.Intersect(compareRange, _
                    compareRange.Parent.UsedRange)

    If compareRange Is Nothing Then Exit Function
    If stringsRange Is Nothing Then Set stringsRange = compareRange
    Set stringsRange = compareRange.Offset(stringsRange.Row - _ 
    compareRange.Row, stringsRange.Column - compareRange.Column)

        For i = 1 To compareRange.Rows.Count
            For j = 1 To compareRange.Columns.Count
               If (Application.CountIf(compareRange.Cells(i, j), _ 
    xCriteria)= 1) Then
                    ConcatIf = ConcatIf & Delimiter & _
    CStr(stringsRange.Cells(i, j))
                End If

            Next j
        Next i
        ConcatIf = Mid(ConcatIf, Len(Delimiter) + 1)

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True

End Function

示例：

+500个项目代码

Sheet1:  

BCD  
CDF  
XLMH  
XPT  
ZPY

200 000 +完整项目代码

Sheet2:  

FDBCDGH  
HSGDBCDSU  
GFD-CDFGDTR  
SBGCDFHUD  
GKJYCDFFDS  
DDFGFDXLMHGFD  
SDGXLMHSDFS  
SDGVSDXLMHFAMN  
DDDSXPTDFGFD  
JUYXPTFADS  
DDDFFZPYDGDFDF

结果应为：

Sheet1：

COLUMN A - COLUMN B  
BCD - FDBCDGH,HSGDBCDSU  
CDF - GFD-CDFGDTR,SBGCDFHUD,GKJYCDFFDS  
XLMH - DDFGFDXLMHGFD,SDGXLMHSDFS,SDGVSDXLMHFAMN  
XPT - DDDSXPTDFGFD,JUYXPTFADS  
ZPY - DDDFFZPYDGDFDF

Answer 1

要使用以下代码，您将需要添加对not working的引用。这使用两个数组并将数据编译为字典。然后可以将其写回到工作表中。当前代码将结果写回到立即窗口，可以使用 Ctrl + G 或Microsoft Scripting Runtime-> View

显示

Immediate Window

Answer 2

要维护有关数据集大小的所有当前功能和可用性，这应该对您有用，并且比原始代码要快。计时时，我使用了400,000个完整商品代码，并在工作表1上应用了concatif公式进行1000次部分匹配，并在9分钟内完成了所有单元格的计算。

Public Function CONCATIF(ByVal arg_rCompare As Range, _
                         ByVal arg_vCriteria As Variant, _
                         Optional ByVal arg_rStrings As Range, _
                         Optional ByVal arg_sDelimiter As String = vbNullString _
  ) As Variant

    Dim aData As Variant
    Dim aStrings As Variant
    Dim aCriteria As Variant
    Dim vString As Variant
    Dim vCriteria As Variant
    Dim aResults() As String
    Dim ixResult As Long
    Dim i As Long, j As Long

    If arg_rStrings Is Nothing Then Set arg_rStrings = arg_rCompare
    If arg_rStrings.Rows.Count <> arg_rCompare.Rows.Count _
    Or arg_rStrings.Columns.Count <> arg_rCompare.Columns.Count Then
        CONCATIF = CVErr(xlErrRef)
        Exit Function
    End If

    If arg_rCompare.Cells.Count = 1 Then
        ReDim aData(1 To 1, 1 To 1)
        aData(1, 1) = arg_rCompare.Value
    Else
        aData = arg_rCompare.Value
    End If

    If arg_rStrings.Cells.Count = 1 Then
        ReDim aStrings(1 To 1, 1 To 1)
        aStrings(1, 1) = arg_rStrings.Value
    Else
        aStrings = arg_rStrings.Value
    End If

    If IsArray(arg_vCriteria) Then
        aCriteria = arg_vCriteria
    ElseIf TypeName(arg_vCriteria) = "Range" Then
        If arg_vCriteria.Cells.Count = 1 Then
            ReDim aCriteria(1 To 1)
            aCriteria(1) = arg_vCriteria.Value
        Else
            aCriteria = arg_vCriteria.Value
        End If
    Else
        ReDim aCriteria(1 To 1)
        aCriteria(1) = arg_vCriteria
    End If

    ReDim aResults(1 To arg_rCompare.Cells.Count)
    ixResult = 0
    For i = LBound(aData, 1) To UBound(aData, 1)
        For j = LBound(aData, 2) To UBound(aData, 2)
            For Each vCriteria In aCriteria
                If aData(i, j) Like vCriteria Then
                    ixResult = ixResult + 1
                    aResults(ixResult) = aStrings(i, j)
                End If
            Next vCriteria
        Next j
    Next i

    If ixResult > 0 Then
        ReDim Preserve aResults(1 To ixResult)
        CONCATIF = Join(aResults, arg_sDelimiter)
    Else
        CONCATIF = vbNullString
    End If

    Erase aData:        aData = vbNullString
    Erase aCriteria:    aCriteria = vbNullString
    Erase aResults

End Function

如何提高部分匹配查找功能的性能？

2 个答案: