Excel VBA Costum формула слишком медленно

Question

У меня есть эта VBA превосходят Costum формулу:

'=ConcatenateRangeIfs(A1;Sheet2!C:C;B1;Sheet2!D:D;Sheet2!G:G;". ") 
Function ConcatenateRangeIfs(_ 
    ByVal match_val1 As String, _ 
    ByVal match_range1 As Range, _ 
    ByVal match_val2 As String, _ 
    ByVal match_range2 As Range, _ 
    ByVal concatenate_range As Range, _ 
    Optional ByVal separator As String _ 
) As String 

'disable uncessary processing to improve performance 
Application.Calculation = xlCalculationManual 
Application.ScreenUpdating = False 
Application.DisplayStatusBar = False 
Application.EnableEvents = False 
ActiveSheet.DisplayPageBreaks = False 

Dim concatedString As String 
Dim toConcatenateCellValue As String 
Dim toConcatenateCellRow As Long 

For Each toConcatenateCell In concatenate_range.SpecialCells(xlConstants, 23) 
    toConcatenateCellValue = toConcatenateCell.Value 
    If Not IsEmpty(toConcatenateCellValue) Then 
     toConcatenateCellRow = toConcatenateCell.Row 
     If match_val1 = match_range1.Cells(toConcatenateCellRow, 1).Value Then 
      If match_val2 = match_range2.Cells(toConcatenateCellRow, 1).Value Then 
       concatedString = concatedString & (separator & toConcatenateCellValue) 
      End If 
     End If 
    End If 
Next toConcatenateCell 

If Len(concatedString) <> 0 Then 
    concatedString = Right$(concatedString, (Len(concatedString) - Len(separator))) 
End If 

'enable disabled processing 
ConcatenateRangeIfs = concatedString 
Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 
Application.DisplayStatusBar = True 
Application.EnableEvents = True 
ActiveSheet.DisplayPageBreaks = True 

End Function 

sheet2 Пример:

лист1 пример, в котором формула в столбце D: D клетки:

Не понимаю, почему, но он занимает слишком много времени и зависает при каждом изменении значений, используемых в формуле. Я попытался отключить ненужные вещи excel и использовать локальные верификации для доступа к свойствам объектов, но не сильно изменил ...

Любое решение для повышения производительности?

Answer 1

Это должно быть быстрее:

Option Explicit 
'=ConcatenateRangeIfs(A1;Sheet2!C:C;B1;Sheet2!D:D;Sheet2!G:G;". ") 
Function ConcatenateRangeIfs(_ 
     ByVal match_val1 As String, _ 
     ByRef match_range1 As Variant, _ 
     ByVal match_val2 As String, _ 
     ByRef match_range2 As Variant, _ 
     ByRef concatenate_range As Variant, _ 
     Optional ByVal separator As String _ 
     ) As String 

    Dim concatedString As String 
    Dim toConcatenateCellValue As String 
    Dim j As Long 

    ' get data into variant arrays 
5 If TypeOf match_range1 Is Range Then 
     Set match_range1 = Intersect(match_range1.Parent.UsedRange, match_range1) 
     match_range1 = match_range1.Value2 
    End If 
    If TypeOf match_range2 Is Range Then 
     Set match_range2 = Intersect(match_range2.Parent.UsedRange, match_range2) 
     match_range2 = match_range2.Value2 
    End If 
    If TypeOf concatenate_range Is Range Then 
     Set concatenate_range = Intersect(concatenate_range.Parent.UsedRange, concatenate_range) 
     concatenate_range = concatenate_range.Value2 
    End If 
    ' 
    ' assumes all arrays are equal length - no error checking 
    ' 
    For j = 1 To UBound(match_range1) 
     If Not IsEmpty(concatenate_range(j, 1)) Then 
      If match_val1 = match_range1(j, 1) Then 
       If match_val2 = match_range2(j, 1) Then 
        concatedString = concatedString & (separator & concatenate_range(j, 1)) 
       End If 
      End If 
     End If 
    Next j 

    If Len(concatedString) <> 0 Then 
     concatedString = Right$(concatedString, (Len(concatedString) - Len(separator))) 
    End If 
ConcatenateRangeIfs = concatedString 

End Function