Option Explicit
Function JoinText(ByVal Delimiter As String, ParamArray Arrays()) As String
Dim aDest() As Variant
Dim aSub As Variant
Dim item As Variant
Dim idx As Long
Dim n As Long
Dim sItem As String
'On Error Resume Next
For n = LBound(Arrays) To UBound(Arrays)
aSub = Arrays(n)
If Not IsArray(aSub) Then aSub = Array(aSub)
For Each item In aSub
If TypeName(item) <> "Error" Then
sItem = CStr(item)
idx = idx + 1
ReDim Preserve aDest(1 To idx)
aDest(idx) = sItem
End If
Next
Next
If idx Then JoinText = Join(aDest, Delimiter)
End Function
Function JoinIf(ByVal Delimiter As String, ByVal CriteriaArray, ByVal Criteria, Optional ByVal TargetArray) As String
Dim aDest() As Variant
Dim aCriteria As Variant
Dim aTarget As Variant
Dim sCriteria As Variant
Dim sTarget As Variant
Dim dic As Object
Dim bComp As Boolean
Dim idx As Long
Dim dTmpVal As Double
'On Error Resume Next
Set dic = CreateObject("Scripting.Dictionary")
If IsMissing(TargetArray) Then TargetArray = CriteriaArray
aCriteria = ConvertTo1DArray(CriteriaArray)
aTarget = ConvertTo1DArray(TargetArray)
If (Not IsArray(aCriteria)) Or (Not IsArray(aTarget)) Then Exit Function
bComp = (InStr("<>=", Left(Criteria, 1)) > 0)
For idx = LBound(aTarget) To UBound(aTarget)
sCriteria = aCriteria(idx): sTarget = aTarget(idx)
If TypeName(sCriteria) <> "Error" Then
If TypeName(sTarget) <> "Error" Then
If bComp And Len(Criteria) Then
dTmpVal = CDbl(aCriteria(idx))
If Evaluate(dTmpVal & Criteria) Then
If Not dic.Exists(sTarget) Then dic.Add sTarget, ""
End If
Else
If (Left(Criteria, 1) = "!") Then
If Not (UCase(sCriteria) Like UCase(Mid(Criteria, 2))) Then
If Not dic.Exists(sTarget) Then dic.Add sTarget, ""
End If
Else
If (UCase(sCriteria) Like UCase(Criteria)) Then
If Not dic.Exists(sTarget) Then dic.Add sTarget, ""
End If
End If
End If
End If
End If
Next
If dic.Count Then
aDest = dic.Keys
JoinIf = Join(aDest, Delimiter)
End If
Set dic = Nothing
'If Err.Number Then MsgBox Err.Description
End Function
Private Function ConvertTo1DArray(ByVal SourceArray)
Dim aDest() As Variant
Dim aSource As Variant
Dim item As Variant
Dim idx As Long
'On Error Resume Next
aSource = SourceArray
If Not IsArray(aSource) Then aSource = Array(aSource)
For Each item In aSource
idx = idx + 1
ReDim Preserve aDest(1 To idx)
aDest(idx) = item
Next
ConvertTo1DArray = aDest
'If Err.Number Then MsgBox Err.Description
End Function
Function UniqueList(ParamArray Arrays())
Dim aDest() As Variant
Dim aSub As Variant
Dim item As Variant
Dim idx As Long
Dim n As Long
Dim sItem As String
Dim dic As Object
'On Error Resume Next
Set dic = CreateObject("Scripting.Dictionary")
For n = LBound(Arrays) To UBound(Arrays)
aSub = Arrays(n)
If Not IsArray(aSub) Then aSub = Array(aSub)
For Each item In aSub
If TypeName(item) <> "Error" Then
sItem = CStr(item)
If Len(sItem) Then
If Not dic.Exists(sItem) Then dic.Add sItem, Empty
End If
End If
Next
Next
If dic.Count Then UniqueList = dic.Keys
Set dic = Nothing
'If Err.Number Then MsgBox Err.Description
End Function
