Excel JoinIf Func on
Func on JOINIF(ByRef IfRange As Range, ByVal Criteria As String, Op onal JoinRange As Range,
Op onal Delimeter As String = ",") As String
'IfRange is the range that will be evaluated by the Criteria
'Criteria is a logical test that can be applied to a cell value.
'Examples of Criteria: "=Steve", ">100", "<>Toronto", "<=-1"
'JoinRange is the range of values that will be concatenated if the corresponding -
'IfRange cell meets the criteria. JoinRange can be le blank if the values to be -
'concatenated are the IfRange values.
'Delimeter is the string that will seperate the concatenated values.
'Default delimeter is a comma.
Dim IfArr() As Variant, JoinArr() As Variant, OutputArr() As String
Dim IfArrDim As Integer, JoinArrDim As Integer
Dim JCount As Long, LoopEnd(1 To 2) As Long
Dim MeetsCriteria As Boolean, Expression As String
Dim i As Long, j As Long
'PARSING THE CRITERIA
Dim Regex As Object
Set Regex = CreateObject("VBScript.RegExp")
Regex.Pa ern = "[=<>]+"
'Looking for comparison operators
Dim Matches As Object
Set Matches = Regex.Execute(Criteria)
If Matches.Count = 0 Then
'If no operators found, assume default "Equal to"
If Not IsNumeric(Criteria) Then
'Add quota on marks to allow string comparisons
Criteria = "=""" & Criteria & """"
End If
Else
If Not IsNumeric(Replace(Criteria, Matches(0), "")) Then
Criteria = Matches(0) & """" & Replace(Criteria, Matches(0), "") & """"
End If
'Add quota on marks to allow string comparisons
End If
'Trim IfRange to UsedRange
Set IfRange = Intersect(IfRange, IfRange.Parent.UsedRange)
'Default op on for op onal JoinRange input
If JoinRange Is Nothing Then
Set JoinRange = IfRange
Else
Set JoinRange = Intersect(JoinRange, JoinRange.Parent.UsedRange)
End If
'DIMENSIONS
'Filling the arrays
If IfRange.Cells.Count > 1 Then
IfArr = IfRange.Value
IfArrDim = Dimensions(IfArr)
Else
ReDim IfArr(1 To 1)
IfArr(1) = IfRange.Value
IfArrDim = 1
End If
If JoinRange.Cells.Count > 1 Then
JoinArr = JoinRange.Value
JoinArrDim = Dimensions(JoinArr)
Else
ReDim JoinArr(1 To 1)
JoinArr(1) = JoinRange.Value
JoinArrDim = 1
End If
'Ini alize the Output array to the smaller of the two input arrays.
ReDim OutputArr(IIf(IfRange.Cells.Count < JoinRange.Cells.Count, IfRange.Cells.Count - 1,
JoinRange.Cells.Count - 1))
'DEFINING THE LOOP PARAMETERS
'Loop ends on the smaller of the two arrays
If UBound(IfArr) > UBound(JoinArr) Then
LoopEnd(1) = UBound(JoinArr)
Else
LoopEnd(1) = UBound(IfArr)
End If
If IfArrDim = 2 Or JoinArrDim = 2 Then
If Not (IfArrDim = 2 And JoinArrDim = 2) Then
'mismatched dimensions
LoopEnd(2) = 1
ElseIf UBound(IfArr, 2) > UBound(JoinArr, 2) Then
LoopEnd(2) = UBound(JoinArr, 2)
Else
LoopEnd(2) = UBound(IfArr, 2)
End If
End If
'START LOOP
If IfArrDim = 1 Then
For i = 1 To LoopEnd(1)
If IsNumeric(IfArr(i)) And IfArr(i) <> "" Then
Expression = IfArr(i) & Criteria
Else
'Add quota on marks to allow string comparisons
Expression = """" & IfArr(i) & """" & Criteria
End If
MeetsCriteria = Applica on.Evaluate(Expression)
If MeetsCriteria Then
If JoinArrDim = 1 Then
OutputArr(JCount) = CStr(JoinArr(i))
Else
OutputArr(JCount) = CStr(JoinArr(i, 1))
End If
JCount = JCount + 1
End If
Next i
Else
For i = 1 To LoopEnd(1)
For j = 1 To LoopEnd(2)
If IsNumeric(IfArr(i, j)) And IfArr(i, j) <> "" Then
Expression = IfArr(i, j) & Criteria
Else
'Add quota on marks to allow string comparisons
Expression = """" & IfArr(i, j) & """" & Criteria
End If
MeetsCriteria = Applica on.Evaluate(Expression)
If MeetsCriteria Then
If JoinArrDim = 1 Then
OutputArr(JCount) = CStr(JoinArr(i))
Else
OutputArr(JCount) = CStr(JoinArr(i, j))
End If
JCount = JCount + 1
End If
Next j
Next i
End If
'END LOOP
ReDim Preserve OutputArr(JCount + 1 * (JCount > 0))
JOINIF = Join(OutputArr, Delimeter)
End Func on
Private Func on Dimensions(var As Variant) As Long
'Credit goes to the great Chip Pearson, [email protected], www.cpearson.com
On Error GoTo Err
Dim i As Long, tmp As Long
While True
i=i+1
tmp = UBound(var, i)
Wend
Err:
Dimensions = i - 1
End Func on
