' ZVI:2011-03-09 http://www.mrexcel.com/forum/showthread.php?t=534231
' Function to return concatenated values of RngToConcat for which Condition happens
' Optional Delim argument (comma) is the delimiter of the resulting list
' Note1: It's faster if performed as array formula via Ctrl-Shift-Enter
' Note2: Decimal separator of numbers is the dot char for all localizations
' Example: =ConcatIf(A1:A10, (B1:B10>1)*(C1:C10<10), CHAR(10))
Function ConcatIf(RngToConcat As Range, Condition, Optional Delim$ = ",") As String
' Variables are reserved for:
' a - for array/value of RngToConcat, processing of array is faster than of range
' b - for array/value of Condition, used also for parsing of Condition part from the caller formula
' r - row counter, rs - rows count
' c - column counter, cs - columns count
' s - concatenated string, used also as temporary variable
' x - temporary vatiable
' vt - vartype of x-variable
' In Dim the suffix "&" is equal to "As Long", "$" = "As String"
Dim vt As VbVarType, a, b, i&, r&, rs&, c&, cs&, s$, x
' Copy range value to variable, processing of VBA array is much faster than processing of range
a = RngToConcat.Value
' If only 1 cell is on the RngToConcat, then a-variable is not array, else it's array
If Not IsArray(a) Then
' There is only single cell in RngToConcat - process it and exit
If Condition Then ConcatIf = a: Exit Function
End If
' Copy Condition to b-variable
b = Condition
' If formula was entered as array formyla by CSE, then b-variable is array, else it's not array
If Not IsArray(b) Then
' Ctrl-Shift-Enter was not performed - do evaluation of Condition formula(s)
With Application.ThisCell
' Application.ThisCell.Formula gives the formula of the caller cell
' Temporarily split that formula with comma delimiter into zero based b() array
b = Split(.Formula, ",")
' b() now is zero based array, b(1) consists Conditional equation
' It is assumed that comma is not used in Conditional equation, if does then more strong parsing is required
s = b(1)
' If optional Delim was not passed into function then delete right round bracket
If UBound(b) = 1 Then s = Left$(s, Len(s) - 1)
' Evaluate Condition in the sheet with caller cell
' Application.ThisCell.Parent is reference to that sheet
b = .Parent.Evaluate(s)
' Clean s for further usage
s = ""
End With
End If
' Calc rows count in b()
rs = UBound(b, 1)
' Calc columns count in b()
cs = UBound(b, 2)
' Loop through b() array,
' if not Error/False/Empty/Zero condition found
' then get value from a() at the same row & column for concatenation
For r = 1 To rs
For c = 1 To cs
x = b(r, c)
If VarType(x) <> vbError Then
' value of b(r, c) is not error - process it
If x Then
' value of b(r, c) is not False/Zero/Empty - get value from a() at the same row & column
x = a(r, c)
vt = VarType(x)
If vt <> vbError Then
' value of a(r, c) is not error - process it
If Len(x) Then
' value of a(r, c) is not empty - provide dot char as the decimal separator for all localizations
If IsNumeric(x) And vt <> vbString Then x = Trim$(Str(x))
' Concatenate the result in temporary s-variable
s = s & x & Delim
End If
End If
End If
End If
Next
Next
' Set result
i = Len(s)
' Delete the last comma in s
If i Then ConcatIf = Left$(s, i - 1)
End Function
