Excel VBA : Concatenate Text Based on Criteria

Function Combinerows(CriteriaRng As Range, Criteria As Variant, _
ConcatenateRng As Range, Optional Delimeter As String = " , ") As Variant
Dim i As Long
Dim strResult As String
On Error GoTo ErrHandler
If CriteriaRng.Count <> ConcatenateRng.Count Then
Combinerows = CVErr(xlErrRef)
Exit Function
End If
For i = 1 To CriteriaRng.Count
If CriteriaRng.Cells(i).Value = Criteria Then
strResult = strResult & Delimeter & ConcatenateRng.Cells(i).Value
End If
Next i
If strResult <> "" Then
strResult = Mid(strResult, Len(Delimeter) + 1)
End If
Combinerows = strResult
Exit Function
ErrHandler:
Combinerows = CVErr(xlErrValue)
End FunUction