Reviews array to find all values matching Col A value
- Creates a string of Results containing the values from Col B
- Removes duplicates from the results
- Adds/Omits " and" depending on if multiple results in final string.
This <myPatternMatchVal> is also available in <myColorMatchval>
= This <Jigsaw> pattern is also available in <Midnight, Sand and Shell>.
= This <Jasper> pattern is also available in <Curry>.
Function LoadRelated(ByRef myArray As Variant, myPatternMatchVal As Variant, myColorMatchVal As Variant, myMatchCol As Variant, myAssembleStringCol As Variant) As String
'Needs an array to loop through - usually aData(cells(1,1),cells(ire1,ice1))
'Needs data to match (Single String: [myColorMatchVal] & the corresponding Column location [myMatchCol])
'Creates a concatenated string of all values matching that string in the array that are located in an offsetting column - will not include the value from the same row: [myColorMatchVal]
'Needs a column location to put the results back into the array: [myAssebmleStringCol]
'Note: Will clean the string so that no dupes are included (by reviewing and re-stringing the string)
' Will include and if multiple values in final string or omit it if it is the only value
'Example: sRelatedSKUs = LoadRelated(myDataArray, sColPattern, sColSKU, iColPattern, iColSKU)
Dim sPatternMatchVal As String, sColorMatchVal As String, iColMatch As Long, iColAssemble As String, iLoop As Long, iLastComma As Long, iFirstComma As Long
Dim aSplitMe As Variant, sNoDupe As String
sPatternMatchVal = myPatternMatchVal
sColorMatchVal = myColorMatchVal
iColMatch = myMatchCol * 1
iColAssemble = myAssembleStringCol * 1
'Return [Blank] value to begin with:
LoadRelated = ""
For iLoop = LBound(myArray) + 1 To UBound(myArray)
If UCase(Trim(myArray(iLoop, iColMatch))) = UCase(Trim(myPatternMatchVal)) Then
LoadRelated = LoadRelated & myArray(iLoop, iColAssemble) & ", "
End If
Next iLoop
'remove any duplicates of the same value as the current color being reviewed
LoadRelated = Replace(LoadRelated, sColorMatchVal & ", ", "", , , vbTextCompare)
'remove trailing commas
If Right(LoadRelated, 2) = ", " Then LoadRelated = Left(LoadRelated, Len(LoadRelated) - 2)
If Right(LoadRelated, 1) = "," Then LoadRelated = Left(LoadRelated, Len(LoadRelated) - 1)
If InStr(1, LoadRelated, ",", vbTextCompare) > 0 Then GoTo gRemoveDupes
GoTo gFunctionComplete
gRemoveDupes:
'Set the value to blank:
sNoDupe = ""
'Split the string into individual chunks
aSplitMe = Split(LoadRelated, ",", , vbTextCompare)
'Loop through each chunk - assess and ignore/re-assemble
For iLoop = LBound(aSplitMe) To UBound(aSplitMe)
'Ignore if already exists in new string
If InStr(1, sNoDupe, aSplitMe(iLoop), vbTextCompare) > 0 Then GoTo gNextRemoveDupeLoop
'Add to new string if not already there.
sNoDupe = sNoDupe & StrConv((aSplitMe(iLoop)), vbProperCase) & ", "
gNextRemoveDupeLoop:
Next iLoop
'final clean when finished with re-assemble
If Right(sNoDupe, 2) = ", " Then sNoDupe = Left(sNoDupe, Len(sNoDupe) - 2)
iLastComma = InStrRev(sNoDupe, ",", , vbTextCompare)
iFirstComma = InStr(1, sNoDupe, ",", vbTextCompare)
If iLastComma > 0 Then sNoDupe = Left(sNoDupe, iLastComma - 1) & " and " & Right(sNoDupe, Len(sNoDupe) - iLastComma)
iFirstComma = InStr(1, sNoDupe, " ", vbTextCompare)
Do While iFirstComma > 0
DoEvents
sNoDupe = Replace(sNoDupe, " ", " ", , , vbTextCompare)
iFirstComma = InStr(1, sNoDupe, " ", vbTextCompare)
Loop
LoadRelated = sNoDupe
GoTo gFunctionComplete
gFunctionComplete:
End Function
'Needs an array to loop through - usually aData(cells(1,1),cells(ire1,ice1))
'Needs data to match (Single String: [myColorMatchVal] & the corresponding Column location [myMatchCol])
'Creates a concatenated string of all values matching that string in the array that are located in an offsetting column - will not include the value from the same row: [myColorMatchVal]
'Needs a column location to put the results back into the array: [myAssebmleStringCol]
'Note: Will clean the string so that no dupes are included (by reviewing and re-stringing the string)
' Will include and if multiple values in final string or omit it if it is the only value
'Example: sRelatedSKUs = LoadRelated(myDataArray, sColPattern, sColSKU, iColPattern, iColSKU)
Dim sPatternMatchVal As String, sColorMatchVal As String, iColMatch As Long, iColAssemble As String, iLoop As Long, iLastComma As Long, iFirstComma As Long
Dim aSplitMe As Variant, sNoDupe As String
sPatternMatchVal = myPatternMatchVal
sColorMatchVal = myColorMatchVal
iColMatch = myMatchCol * 1
iColAssemble = myAssembleStringCol * 1
'Return [Blank] value to begin with:
LoadRelated = ""
For iLoop = LBound(myArray) + 1 To UBound(myArray)
If UCase(Trim(myArray(iLoop, iColMatch))) = UCase(Trim(myPatternMatchVal)) Then
LoadRelated = LoadRelated & myArray(iLoop, iColAssemble) & ", "
End If
Next iLoop
'remove any duplicates of the same value as the current color being reviewed
LoadRelated = Replace(LoadRelated, sColorMatchVal & ", ", "", , , vbTextCompare)
'remove trailing commas
If Right(LoadRelated, 2) = ", " Then LoadRelated = Left(LoadRelated, Len(LoadRelated) - 2)
If Right(LoadRelated, 1) = "," Then LoadRelated = Left(LoadRelated, Len(LoadRelated) - 1)
If InStr(1, LoadRelated, ",", vbTextCompare) > 0 Then GoTo gRemoveDupes
GoTo gFunctionComplete
gRemoveDupes:
'Set the value to blank:
sNoDupe = ""
'Split the string into individual chunks
aSplitMe = Split(LoadRelated, ",", , vbTextCompare)
'Loop through each chunk - assess and ignore/re-assemble
For iLoop = LBound(aSplitMe) To UBound(aSplitMe)
'Ignore if already exists in new string
If InStr(1, sNoDupe, aSplitMe(iLoop), vbTextCompare) > 0 Then GoTo gNextRemoveDupeLoop
'Add to new string if not already there.
sNoDupe = sNoDupe & StrConv((aSplitMe(iLoop)), vbProperCase) & ", "
gNextRemoveDupeLoop:
Next iLoop
'final clean when finished with re-assemble
If Right(sNoDupe, 2) = ", " Then sNoDupe = Left(sNoDupe, Len(sNoDupe) - 2)
iLastComma = InStrRev(sNoDupe, ",", , vbTextCompare)
iFirstComma = InStr(1, sNoDupe, ",", vbTextCompare)
If iLastComma > 0 Then sNoDupe = Left(sNoDupe, iLastComma - 1) & " and " & Right(sNoDupe, Len(sNoDupe) - iLastComma)
iFirstComma = InStr(1, sNoDupe, " ", vbTextCompare)
Do While iFirstComma > 0
DoEvents
sNoDupe = Replace(sNoDupe, " ", " ", , , vbTextCompare)
iFirstComma = InStr(1, sNoDupe, " ", vbTextCompare)
Loop
LoadRelated = sNoDupe
GoTo gFunctionComplete
gFunctionComplete:
End Function