Nadine
New Member
- Joined
- May 12, 2020
- Messages
- 32
- Office Version
- 365
- Platform
- Windows
Hello and thank you for any attention my post may receive.
I am attempting to concatenate unique strings with criteria and ignore blank cells, which the code below (courtesy of VBasic2008) does nicely. Its purpose is to retrieve unique ((comma) separated) (ResultSeparator) data, determined by a criteria (Criteria) in a specified column (CriteriaRange), from another specified column (SourceRange), possibly containing (comma) separated (StringSeparator) strings. The formula used in the wb is =CritJoe(SourceRange, CriteriaRange, Criteria), which in my case is
.
However, this code only looks at rows in a single column (e.g. col B), and I would like to resize to rows in 4 contiguous columns (e.g. col B to E).
What changes do I need to make to the below code to achieve my desired result?
If a simple workbook is needed then
I am attempting to concatenate unique strings with criteria and ignore blank cells, which the code below (courtesy of VBasic2008) does nicely. Its purpose is to retrieve unique ((comma) separated) (ResultSeparator) data, determined by a criteria (Criteria) in a specified column (CriteriaRange), from another specified column (SourceRange), possibly containing (comma) separated (StringSeparator) strings. The formula used in the wb is =CritJoe(SourceRange, CriteriaRange, Criteria), which in my case is
Excel Formula:
=CritJoe(B:E,F:F,F1)However, this code only looks at rows in a single column (e.g. col B), and I would like to resize to rows in 4 contiguous columns (e.g. col B to E).
What changes do I need to make to the below code to achieve my desired result?
If a simple workbook is needed then
VBA Code:
' Written by VBasic2008
Function CritJoe(SourceRange As Range, CriteriaRange As Range, _
Criteria As String, Optional StringSeparator As String = "", _
Optional ResultSeparator As String = ", ") As String
Dim vntS ' Source Array (1-based, 2-dimensional)
Dim vntC ' Criteria Array (1-based, 2-dimensional)
Dim vntSS ' Source String Array (0-based, 1-dimensional)
Dim vntR ' Resulting Array (0-based, 1-dimensional)
Dim i As Long ' Source & Criteria Array Elements Counter
Dim j As Long ' Resulting Array Elements Counter
Dim k As Long ' Source String Array Elements Counter
Dim UB As Long ' Current Resulting Array's Upper Bound
Dim strS As String ' Current Source String
Dim strR As String ' Resulting String
' Check if SourceRange and CriteriaRange have the same number of rows and
' have the same first row number.
If SourceRange.Rows.Count <> CriteriaRange.Rows.Count Or _
SourceRange.Rows(1).Row <> CriteriaRange.Rows(1).Row Then GoTo RowsError
' Note: The relevant data has to be in the first column of each range if (accidentally) more columns have been selected.
' Copy first column of the Ranges to Arrays.
vntS = SourceRange.Cells(1).Resize(SourceRange.Rows.Count)
vntC = CriteriaRange.Cells(1).Resize(CriteriaRange.Rows.Count)
' Write relevant data to Resulting Array.
For i = 1 To UBound(vntS)
If vntC(i, 1) = Criteria Then
strS = vntS(i, 1)
If StringSeparator <> "" Then
' Write Resulting String to Resulting Array using
' StringSeparator.
GoSub SplitString
Else
' Write Resulting String to Resulting Array without using StringSeparator.
GoSub StringToArray
End If
End If
Next
' Write relevant data from Resulting Array to Resulting String.
If IsArray(vntR) Then
strR = vntR(0)
If UBound(vntR) > 0 Then
For j = 1 To UBound(vntR)
strR = strR & ResultSeparator & vntR(j)
Next
End If
End If
CritJoe = strR
Exit Function
' Write Resulting String to Resulting Array using StringSeparator.
SplitString:
vntSS = Split(strS, StringSeparator)
For k = 0 To UBound(vntSS)
strS = Trim(vntSS(k))
GoSub StringToArray
Next
Return
' Write Resulting String to Resulting Array.
StringToArray:
If IsArray(vntR) Then
' Handle all except the first element in Resulting Array.
UB = UBound(vntR)
For j = 0 To UB
If vntR(j) = strS Then Exit For
Next
If j = UB + 1 Then
ReDim Preserve vntR(j): vntR(j) = strS
End If
Else
' Handle only first element in Resulting Array.
ReDim vntR(0): vntR(0) = strS
End If
Return
RowsError:
CritJoe = "Rows Error!"
End Function
