Excel VBA costum Formel zu langsam

Question

ich diese vba haben Excel costum Formel:

'=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 

Das sheet2 Beispiel:

Das sheet1 Beispiel, wo die Formel in Spalte D: D Zellen:

Ich verstehe nicht warum, aber es dauert zu lange und einfriert jedes Mal, wenn ich einen der in der Formel verwendeten Werte ändere. Ich habe versucht deaktivieren unnötige Excel-Sachen, und verwenden Sie lokale Veriables für den Zugriff auf Objekte Eigenschaften, aber nicht viel geändert ...

Irgendwelche suggestion, um die Leistung zu verbessern?

Answer 1

Dies sollte schneller sein:

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