Option Explicit
Function JoinText(ByVal Delimiter As String, ParamArray Arrays()) As String
Dim aTmp, arrDes(), Item, tmp As String
Dim idx As Long, n As Long
'On Error Resume Next
For idx = LBound(Arrays) To UBound(Arrays)
aTmp = Arrays(idx)
If Not IsArray(aTmp) Then aTmp = Array(aTmp)
For Each Item In aTmp
If TypeName(Item) <> "Error" Then
tmp = CStr(Item)
n = n + 1
ReDim Preserve arrDes(1 To n)
arrDes(n) = tmp
End If
Next
Next
If n Then JoinText = Join(arrDes, Delimiter)
End Function
Function UniqueList(ParamArray sArray())
Dim Item, tmpArr, SubArr, tmp
'On Error Resume Next
With CreateObject("Scripting.Dictionary")
For Each SubArr In sArray
tmpArr = SubArr
If Not IsArray(tmpArr) Then tmpArr = Array(tmpArr)
For Each Item In tmpArr
If TypeName(Item) <> "Error" Then
tmp = CStr(Item)
If Len(tmp) Then
If Not .Exists(tmp) Then .Add tmp, ""
End If
End If
Next
Next
If .Count Then UniqueList = .Keys
End With
End Function
Function JoinIf(ByVal Delimiter As String, ByVal CriteriaArray, ByVal Criteria, Optional ByVal TargetArray) As String
Dim arrDes()
Dim arrTmpCrit As Variant
Dim arrTmpDest As Variant
Dim strCrit As Variant
Dim strDest As Variant
Dim dic As Object
Dim bComp As Boolean
Dim idx As Long
Dim dTmpVal As Double
Set dic = CreateObject("Scripting.Dictionary")
If IsMissing(TargetArray) Then TargetArray = CriteriaArray
arrTmpCrit = ConvertTo1DArray(CriteriaArray)
arrTmpDest = ConvertTo1DArray(TargetArray)
If (Not IsArray(arrTmpCrit)) Or (Not IsArray(arrTmpDest)) Then Exit Function
'On Error Resume Next
bComp = (InStr("<>=", Left(Criteria, 1)) > 0)
For idx = LBound(arrTmpDest) To UBound(arrTmpDest)
strCrit = arrTmpCrit(idx): strDest = arrTmpDest(idx)
If TypeName(strCrit) <> "Error" Then
If TypeName(strDest) <> "Error" Then
If bComp And Len(Criteria) Then
dTmpVal = CDbl(arrTmpCrit(idx))
If Evaluate(dTmpVal & Criteria) Then
If Not dic.Exists(strDest) Then dic.Add strDest, ""
End If
Else
If (Left(Criteria, 1) = "!") Then
If Not (UCase(strCrit) Like UCase(Mid(Criteria, 2))) Then
If Not dic.Exists(strDest) Then dic.Add strDest, ""
End If
Else
If (UCase(strCrit) Like UCase(Criteria)) Then
If Not dic.Exists(strDest) Then dic.Add strDest, ""
End If
End If
End If
End If
End If
Next
If dic.Count Then
arrDes = dic.Keys
JoinIf = Join(arrDes, Delimiter)
End If
'If Err.Number Then MsgBox Err.Description
End Function
Private Function ConvertTo1DArray(ByVal SourceArray)
Dim arrDest()
Dim arrSrc As Variant
Dim Item As Variant
Dim idx As Long
'On Error Resume Next
arrSrc = SourceArray
If Not IsArray(arrSrc) Then arrSrc = Array(arrSrc)
For Each Item In arrSrc
idx = idx + 1
ReDim Preserve arrDest(1 To idx)
arrDest(idx) = Item
Next
ConvertTo1DArray = arrDest
'If Err.Number Then MsgBox Err.Description
End Function
docs.google.com
