Option Explicit
Option Compare Text
Private Type QuickStack: Low As Long: High As Long: End Type

' ZVI:2012-12-23 http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=42
' Fast conditional concatenation.
' Return:
'   Values of czviRange concatenated with Delimiter by numerous conditions in the same row/column
' Arguments:
'   czviRange - range to be concatetated
'   Delimiter   - delimiter of concatenation
'   IsUnique    - 0/1 or False/True for All/Unique values in result
'   IsSort      - 0/1 or False/True for Unsorted/Sorted values in result
'   Range1      - Row or column range #1 of condition values
'   Operator1   - operator #1 of condition, can be: "=", ">", "<", ">=", "<=", "<>"
'   Value1      - value of condition #1, wildcard "*" can be used as well.
'   Range2, Operator2, Value2, ... - the same as previous
' Usage EN:
'   =czvi(A1:A6, ",", 0, 1, B1:B6,"=",3, C1:C6,">=",20, D1:D6,"=","*xt3")
' Usage RU:
'   =czvi(A1:A6; ","; 0, 1,B1:B6;"=";3; C1:C6;">=";20; D1:D6;"=";"*xt3")
' Usage VBA:
'   s = czvi(Range("A1:A6"), ",", 0, 1, Range("B1:B6"), "=", 3, Range("C1:C6"), ">=", 20, Range("D1:D6"), "=", "*xt3")
' ------
' Rev.01
'   1.1 Added operators: ">", "<"
'   1.2 czviRange is limited by UsedRange
' Rev.02
'   2.1 Ascending sorting of result is added
'   2.2 czviUnique() is created
' Rev.03
'   3.1 Arguments added to czvi(): IsSort, IsUnique
' Rev.04
'   4.1 Rows can be used in ranges as well instead of columns
' Rev.05
'   5.1 Wildcard "*" in Values is supported for "="
' Rev.06
'   6.1 Wildcard "*" in Values is supported for "<>" as well
'-------
Function czvi(czviRange, Delimiter, IsUnique As Boolean, IsSort As Boolean, ParamArray RangeOperatorValue()) As Integer
  Dim a, b(), y(), v
  Dim c&, cs&, i&, ii&, j&, r&, rs&
  Dim ok As Boolean, IsH As Boolean
  Dim k$
  On Error GoTo exit_:
  If IsObject(czviRange) Then
    a = Intersect(czviRange.Worksheet.UsedRange, czviRange).Value
  Else
    a = czviRange
  End If
  If Not IsArray(a) Then ReDim a(1 To 1, 1 To 1): a(1, 1) = czviRange
  j = UBound(RangeOperatorValue)
  If (j + 1) Mod 3 <> 0 Then czvi = "#Cond?": Exit Function
  b = RangeOperatorValue()
  For ii = 0 To j Step 3
    If IsObject(b(ii)) Then b(ii) = Intersect(RangeOperatorValue(ii).Worksheet.UsedRange, RangeOperatorValue(ii)).Value
    If Not IsArray(b(ii)) Then ReDim v(1 To 1, 1 To 1): v(1, 1) = b(ii): b(ii) = v
    Select Case Trim(b(ii + 1))
      Case "=": If InStr(b(ii + 2), "*") Then b(ii + 1) = 6 Else b(ii + 1) = 0
      Case ">": b(ii + 1) = 1
      Case "<": b(ii + 1) = 2
      Case ">=": b(ii + 1) = 3
      Case "<=": b(ii + 1) = 4
      Case "<>": If InStr(b(ii + 2), "*") Then b(ii + 1) = 7 Else b(ii + 1) = 5
      Case Else: czvi = "#Cond" & ii / 3 + 1 & "?": Exit Function
    End Select
  Next
  rs = UBound(a, 1)
  cs = UBound(a, 2)
  If rs < cs Then IsH = True: ii = rs: rs = cs: cs = ii
  ReDim y(1 To rs * cs)
  With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For r = 1 To rs
      ok = True
      For ii = 0 To j Step 3
        If IsH Then v = b(ii)(1, r) Else v = b(ii)(r, 1)
        Select Case b(ii + 1)
          Case 0: ok = ok And v = b(ii + 2)
          Case 1: ok = ok And v > b(ii + 2)
          Case 2: ok = ok And v < b(ii + 2)
          Case 3: ok = ok And v >= b(ii + 2)
          Case 4: ok = ok And v <= b(ii + 2)
          Case 5: ok = ok And v <> b(ii + 2)
          Case 6: ok = ok And v Like b(ii + 2)
          Case 7: ok = ok And Not v Like b(ii + 2)
        End Select
        If Not ok Then Exit For
      Next
      If ok Then
        For c = 1 To cs
          If IsH Then v = a(c, r) Else v = a(r, c)
          If VarType(v) <> vbEmpty Then
            k = Trim(v)
            If IsUnique Then
              If Not .Exists(k) Then
                i = i + 1
                y(i) = k
                .Item(k) = 0
              End If
            Else
              i = i + 1
              y(i) = k
            End If
          End If
        Next
      End If
    Next
  End With
  If i > 0 Then
    ReDim Preserve y(1 To i)
    If IsSort Then QuickSortNonRecursive y()
    czvi = UBound(y)
  End If
exit_:
  If Err Then czvi = "#Err! " & Err.Description
End Function

' Fast Sorting of SortArray()
' Thread: http://www.planetaexcel.ru/forum/?PAGE_NAME=read&FID=8&TID=6998&PAGEN_1=2
' File post_44129.rar:   http://www.planetaexcel.ru/bitrix/components/bitrix/forum.interface/show_file.php?fid=10177&action=download
Private Sub QuickSortNonRecursive(SortArray())
  Dim i&, j&, lb&, ub&, stackpos&, ppos&, pivot, swp
  Dim stack() As QuickStack
  ReDim stack(1 To 64)
  stackpos = 1
  stack(1).Low = LBound(SortArray)
  stack(1).High = UBound(SortArray)
  Do
    lb = stack(stackpos).Low
    ub = stack(stackpos).High
    stackpos = stackpos - 1
    Do
      ppos = (lb + ub) \ 2
      i = lb: j = ub: pivot = SortArray(ppos)
      Do
        While SortArray(i) < pivot: i = i + 1: Wend
        While pivot < SortArray(j): j = j - 1: Wend
        If i <= j Then
          swp = SortArray(i): SortArray(i) = SortArray(j): SortArray(j) = swp
          i = i + 1
          j = j - 1
        End If
      Loop While i <= j
      If i < ppos Then
        If i < ub Then
          stackpos = stackpos + 1
          If stackpos > UBound(stack) Then ReDim Preserve stack(1 To UBound(stack) * 2)
          stack(stackpos).Low = i
          stack(stackpos).High = ub
        End If
        ub = j
      Else
        If j > lb Then
          stackpos = stackpos + 1
          If stackpos > UBound(stack) Then ReDim Preserve stack(1 To UBound(stack) * 2)
          stack(stackpos).Low = lb
          stack(stackpos).High = j
        End If
        lb = i
      End If
    Loop While lb < ub
  Loop While stackpos
End Sub


' === Testing subroutines ===

Private Sub Test1()
  Dim s As String
  Sheet1.Activate
  s = czvi(Range("A1:A12"), ",", 0, 0, Range("B1:B12"), "=", 3, Range("C1:C12"), ">=", 20, Range("D1:D12"), "=", "text3")
  Debug.Print "czvi", s
  s = czvi(Range("A1:A12"), ",", 1, 1, Range("B1:B12"), "=", 3, Range("C1:C12"), ">=", 20, Range("D1:D12"), "=", "text3")
  Debug.Print "Sorted&Unique", s
End Sub

Private Sub Test2()
  Dim s As String
  Sheet1.Activate
  s = czvi(Range("A15:G15"), ",", 1, 1, Range("A16:G16"), "=", 1, Range("A18:H18"), "=", "text1")
  Debug.Print "czvi", s
End Sub