Searching for several exact substrings in one String - vba

Question

I have a problem I've been working on for a while but cannot seem to get there. I have a list of about 6000 material descriptions and I want to pull out a specific searched for word.
So if the description is 'Handschuhe-Wunder-20XV28', and the search word was 'Wunder', this material would then have a new column that said 'Wunder'. However, I might also want to search for the word 'Super', and I would like this to appear in the same column.
This search would only pick up the exact words, so if it was looking for 'Super', it wouldn't return a result if it found the word 'Superman'.
I had a formula which can do this:
=IF(AQ2=1,IF(SUM(IF(ISNUMBER(SEARCH(Search!A$2, K2)), IF(COUNT((IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))>122, 1, "")), (IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))<65, 1, "")), (IF(SEARCH(Search!A$2, K2)-1<1, 1, ""))), IF(COUNT((IF(CODE(MID(K2, SEARCH(Search!A$2, K2)+LEN(Search!A$2), 1))>122, 1, "")), (IF(CODE(MID(K2, SEARCH(Search!A$2, K2)+LEN(Search!A$2), 1))<65, 1, "")), (IF((SEARCH(Search!A$2, K2)+LEN(Search!A$2)+1)>LEN(K2), 1, ""))), 1, 0), 0), 0))>0,Search!A$2,0),"")
Where AQ2 contained the initial quick search:
=IF(IFERROR(SEARCH(Search!$A$2,'Raw Data Working'!K2),0)=0,"",1)
This was to improve efficiency as the first formula separates non-alphanumerical characters to find the exact word, after the second formula I posted works out whether it is worth search at all.
I tried recording this in visual basic, with the idea that there would be columns increasing as part of a for loop, with two columns for each search item. I would then somehow bring across the results of any searches into one column. However, when I record the long formula in VBA, despite including breaks, it still does not work.
I would be grateful for any help, suggestions or ideas. Quite simply, it is looking in one piece of text, to see whether the text includes either of several works. And they would have to be exact matches.
Thanks everyone!

Answer 1

Based on what has been discussed, the following should meet your needs or at least be a lot closer to what you imagine.
First is a function that accepts all the characters you wish to delimit the string with:
Note: This function is actually kind of awesome.
Function MultiSplitX(ByVal SourceText As String, RemoveBlankItems As Boolean, ParamArray Delimiters()) As String()
Dim a As Integer, b As Integer, n As Integer
Dim i As Integer: i = 33
Dim u As Variant, v As Variant
Dim tempArr() As String, finalArr() As String, fDelimiters() As String
If InStr(TypeName(Delimiters(0)), "()") <> 0 And LBound(Delimiters) = UBound(Delimiters) Then
ReDim fDelimiters(LBound(Delimiters(0)) To UBound(Delimiters(0))) 'If passing array vs array items then
For a = LBound(Delimiters(0)) To UBound(Delimiters(0)) 'build that array
fDelimiters(a) = Delimiters(0)(a)
Next a
Else
fDelimiters = Delimiters(0)
End If
Do While InStr(SourceText, Chr(i)) <> 0 'Find an unused character
i = i + 1
Loop
For a = LBound(fDelimiters) To UBound(fDelimiters) 'Sort Delimiters by length
For b = a + 1 To UBound(fDelimiters)
If Len(fDelimiters(a)) < Len(fDelimiters(b)) Then
u = fDelimiters(b)
fDelimiters(b) = fDelimiters(a)
fDelimiters(a) = u
End If
Next b
Next a
For Each v In fDelimiters 'Replace Delimiters with a common character
SourceText = Replace(SourceText, v, Chr(i))
Next
tempArr() = Split(SourceText, Chr(i)) 'Remove empty array items
If RemoveBlankItems = True Then
ReDim finalArr(LBound(tempArr) To UBound(tempArr))
n = LBound(tempArr)
For i = LBound(tempArr) To UBound(tempArr)
If tempArr(i) <> "" Then
finalArr(n) = tempArr(i)
n = n + 1
End If
Next i
n = n - 1
ReDim Preserve finalArr(LBound(tempArr) To n)
MultiSplitX = finalArr
Else: MultiSplitX = tempArr
End If
Erase finalArr
Erase tempArr
End Function
Next is the routine that finds all applicable matches:
Sub SearchDynamicDelimit()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(2)
Dim strTest As New Collection
Dim udRange As Range: Set udRange = ws.Range("D2", ws.Cells(ws.Rows.Count, "D").End(xlUp)) '<~~Change to your Search Range
Dim myCell, myMatch, myString, i, delimiter, d, s, t, u, c
Dim temp() As String, myDelimiter() As String, delNotInSearch() As String, delInSearch() As String, tempCell As String
Dim delimitInSearch As Boolean: delimitInSearch = False
Dim delString As String, searchString As String
For Each myMatch In udRange
If myMatch.Value <> "" Then strTest.Add myMatch.Value
searchString = searchString & CStr(myMatch.Value)
Debug.Print myMatch.Value & " " & myMatch.Address
Next myMatch
ws.Range("B2", ws.Cells(ws.Rows.Count, "B")).Clear '<~~Change to where you want the results to populate
delString = "_|-|.|/|<|>|;|:|[|]|\|{|}| |(|,|)" '<~~Change to the delimiters you want. Separate them with any unique character.
myDelimiter() = Split(delString, "|") '<~~Make sure the unique character you chose above is the same here.
ReDim delNotInSearch(LBound(myDelimiter) To UBound(myDelimiter))
ReDim delInSearch(LBound(myDelimiter) To UBound(myDelimiter))
t = LBound(myDelimiter)
u = LBound(myDelimiter)
For s = LBound(myDelimiter) To UBound(myDelimiter)
If InStr(searchString, myDelimiter(s)) = 0 Then
delNotInSearch(t) = myDelimiter(s)
Debug.Print "delNotInSearch(" & t & ") = " & delNotInSearch(t)
t = t + 1
Else
delInSearch(u) = myDelimiter(s)
Debug.Print "delInSearch(" & u & ") = " & delInSearch(u)
u = u + 1
End If
Next s
t = t - 1
u = u - 1
If t <> -1 Then ReDim Preserve delNotInSearch(LBound(myDelimiter) To t)
If u <> -1 Then ReDim Preserve delInSearch(LBound(myDelimiter) To u)
If delInSearch(LBound(delInSearch)) <> "" Then delimitInSearch = True
If strTest.Count > 0 Then
For Each myCell In ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp)) '<~~Change to range being searched
If myCell.Value = "" Then GoTo SkipBlanks
If delimitInSearch = True Then
temp() = MultiSplitX(myCell.Value, True, delNotInSearch())
For i = 0 To UBound(temp)
For Each myString In strTest
If StrComp(temp(i), myString, vbTextCompare) = 0 Then
If ws.Range("B" & myCell.Row).Value = "" Then 'If you only want it to show 1 search result, remove the IF statement entirely
ws.Range("B" & myCell.Row).Value = temp(i) 'And keep this line only. Change "B" to where you want the results to go
Else: ws.Range("B" & myCell.Row).Value = ws.Range("B" & myCell.Row).Value & ", " & temp(i)
End If
End If
Next myString
Next i
Erase temp
End If
temp() = MultiSplitX(myCell.Value, True, delInSearch())
For i = 0 To UBound(temp)
For Each myString In strTest
If StrComp(temp(i), myString, vbTextCompare) = 0 Then
If ws.Range("B" & myCell.Row).Value = "" Then 'If you only want it to show 1 search result, remove the IF statement entirely
ws.Range("B" & myCell.Row).Value = temp(i) 'And keep this line only. Change "B" to where you want the results to go
Else: ws.Range("B" & myCell.Row).Value = ws.Range("B" & myCell.Row).Value & ", " & temp(i)
End If
End If
Next myString
Next i
Erase temp
SkipBlanks:
Next myCell
Else: MsgBox "Nothing found to search...", Title:="No Search Item"
End If
End Sub
On my sample workbook, I yielded the following results using the routine in conjuction with the MultiSplit function:
Notice Sich.Okay was properly found, even though "." being used as a delimiter.
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
ORIGINAL ANSWER BELOW FOR THOSE IT MAY HELP
If you want a method using VBA you could try something like this:
Sub ColorMatchingString()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim strTest As Collection: Set strTest = New Collection
Dim udRange As Range: Set udRange = ws.Range("E1:G1") 'Define Search Ranges
Dim myCell, myMatch, myString, i, nextRR As Long
Dim temp() As String, tempLength As Integer, stringLength As Integer
nextRR = 3
For Each myMatch In udRange 'Build the collection with Search Range Values
strTest.Add myMatch.Value
Next myMatch
If ws.Range("E1").Value <> "" Or ws.Range("F1").Value <> "" Or ws.Range("G1").Value <> "" Then
For Each myCell In ws.Range("A1:A50")
temp() = Split(myCell.Text, "-")
startLength = 0
stringLength = 0
For i = 0 To UBound(temp)
tempLength = Len(temp(i))
stringLength = stringLength + tempLength + 2
For Each myString In strTest
If StrComp(temp(i), myString, vbTextCompare) = 0 Then
ws.Range("H" & nextRR).Value = myCell.Text
ws.Range("I" & nextRR).Value = myCell.Address
startLength = stringLength - tempLength - 2
ws.Range("H" & nextRR).Characters(startLength, tempLength).Font.Color = vbRed
nextRR = nextRR + 1
End If
Next myString
Next i
Erase temp
Next myCell
Else: MsgBox "Nothing found to search...", Title:="No Search Item"
End If
End Sub
What this will do is find your search items and show them in a new column, as well as show you where the item was found.

Answer 2

You could still keep a formula based approach, using an array formula. So, using the list being in e1:e4 and search criteria 1 in I1 and search criteria 2 in J1, I used the following
=INDEX($E$1:$E$4,SMALL(IF((NOT(ISERROR(SEARCH($I$1 & " ",$E$1:$E$4))))+(NOT(ISERROR(SEARCH($J$1 & " ",$E$1:$E$4)))),ROW($E$1:$E$4)),ROWS($E$1:$E1)))
and dragged down
Results can be seen in column G
Based on the comments, I've done the below array formula, this time, I've my data in A1:A5 and my search terms in D1 and D2.
=IFERROR(INDEX($A$1:$A$5 & " (" & $D$1 &")",SMALL(IF(NOT(ISERROR(SEARCH($D$1,$A$1:$A$5))),ROW($A$1:$A$5)),ROWS($B$1:$B1))),IFERROR(INDEX($A$1:$A$5 & " (" & $D$2 &")",SMALL(IF(NOT(ISERROR(SEARCH($D$2,$A$1:$A$5))),ROW($A$1:$A$5)),ROWS($B$1:$B1)-SUM(IF(NOT(ISERROR(SEARCH($D$1,$A$1:$A$5))),1,0)))),"<>"))
This looks as follows

Answer 3

This present two solutions:
1. Method to work with long formulas in VBA
2. VBA code to classify all Materials Description at once.
1. Method to work with long formulas in VBA
This formula is too long for VBA.
=IF(AQ2=1,IF(SUM(IF(ISNUMBER(SEARCH(Search!A$2, K2)), IF(COUNT((IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))>122, 1, "")), (IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))<65, 1, "")), (IF(SEARCH(Search!A$2, K2)-1<1, 1, ""))), IF(COUNT((IF(CODE(MID(K2, SEARCH(Search!A$2, K2)+LEN(Search!A$2), 1))>122, 1, "")), (IF(CODE(MID(K2, SEARCH(Search!A$2, K2)+LEN(Search!A$2), 1))<65, 1, "")), (IF((SEARCH(Search!A$2, K2)+LEN(Search!A$2)+1)>LEN(K2), 1, ""))), 1, 0), 0), 0))>0,Search!A$2,0),"")
To write long Formulas with VBA, we need to slice it down in several parts using variables.
So let’s first see the formula broken down by excel functions:
=IF(AQ2=1,
IF(
SUM(
IF(
ISNUMBER(SEARCH(Search!A$2, K2)),
IF(
COUNT(
(IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))>122, 1, "")),
(IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))<65, 1, "")),
(IF(SEARCH(Search!A$2, K2)-1<1, 1, ""))),
IF(
COUNT(
(IF(CODE(MID(K2, SEARCH(Search!A$2, K2)+LEN(Search!A$2), 1))>122, 1, "")),
(IF(CODE(MID(K2, SEARCH(Search!A$2, K2)+LEN(Search!A$2), 1))<65, 1, "")),
(IF((SEARCH(Search!A$2, K2)+LEN(Search!A$2)+1)>LEN(K2), 1, ""))
), 1, 0),
0),
0)
)>0,
Search!A$2,0)
,"")
This formula has basically 4 parts:
• It checks what you call the quick search in cell AQ2 - Part 1
=IF(AQ2=1,
IF(
SUM(
IF(
ISNUMBER(SEARCH(Search!A$2, K2)),
• Validates the character immediately before and after the word found:
Part 2 - before:
IF(
COUNT(
(IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))>122, 1, "")),
(IF(CODE(MID(K2, SEARCH(Search!A$2, K2)-1, 1))<65, 1, "")),
(IF(SEARCH(Search!A$2, K2)-1<1, 1, ""))),
Part 3 - after:
IF(
COUNT(
(IF(CODE(MID(K2, SEARCH(Search!A$2, K2)+LEN(Search!A$2), 1))>122, 1, "")),
(IF(CODE(MID(K2, SEARCH(Search!A$2, K2)+LEN(Search!A$2), 1))<65, 1, "")),
(IF((SEARCH(Search!A$2, K2)+LEN(Search!A$2)+1)>LEN(K2), 1, ""))
), 1, 0),
0),
0)
)>0,
• Then returns the result - Part 4
Search!A$2,0)
,"")
Following the same logic I have modified your formula:
=IF(
IF(OR(
IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
IF(IFERROR(SEARCH(Search!A$2,$K2),0)=1,0,-1),1))),0)
<65,
IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
IF(IFERROR(SEARCH(Search!A$2,$K2),0)=1,0,-1),1))),0)
>122),0,1)
+
IF(OR(
IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
LEN(Search!A$2),1))),0)
<65,
IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
LEN(Search!A$2),1))),0)
>122),0,1)
<>0,"",Search!A$2)
Now we can clearly see the fundamental parts of the formula:
• Getting the character immediately before:
IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
IF(IFERROR(SEARCH(Search!A$2,$K2),0)=1,0,-1),1))),0)
• Getting the character immediately after:
IFERROR(CODE(TRIM(MID($K2,IFERROR(SEARCH(Search!A$2,$K2),0)+
LEN(Search!A$2),1))),0)
Now we use variables to define the formula, but first in order to make the formula flexible so it can be applied with any reference let’s modify the “hard coded” references with strings that can be replaced with the references obtained at run time:
Substitute $K2 with #Cll and Search!A$2 with #Srch
The final code is something like this:
Sub Vba_Long_Formula()
Dim sCll As String, sSrch As String
sCll = "$K2"
sSrch = "Search!A$2"
Dim sFmlIni As String, sFmlEnd As String 'Formulas for the before and after characters
'Chr(10) is used to ease reading by breaking the formula by line
sFmlIni = "IFERROR(CODE(TRIM(MID(#Cll,IFERROR(SEARCH(#Srch,#Cll),0)+" & Chr(10) & _
"IF(IFERROR(SEARCH(#Srch,#Cll),0)=1,0,-1),1))),0)"
sFmlEnd = "IFERROR(CODE(TRIM(MID(#Cll,IFERROR(SEARCH(#Srch,#Cll),0)+" & Chr(10) & _
"LEN(#Srch),1))),0)"
Dim sFml1 As String 'Formula to be applied
sFml1 = "=IF(" & Chr(10) & _
"IF(OR(" & Chr(10) & sFmlIni & "<65," & Chr(10) & sFmlIni & ">122),0,1)+" & Chr(10) & _
"IF(OR(" & Chr(10) & sFmlEnd & "<65," & Chr(10) & sFmlEnd & ">122),0,1)<>0,"""",#Srch)"
sFml1 = Replace(Replace(sFml1, "#Cll", sCll), "#Srch", sSrch)
ThisWorkbook.Sheets("Raw Data Working").Range("AR2:AR4").Formula = sFml1
End Sub
Hope the above solves the problem with the long formula in VBA.
2. VBA code to classify all Materials Description at once.
However, if you are using VBA then it’s more efficient to run the entire process using VBA to classify all the Material Descriptions with the corresponding Brands.
This code assumes the following (change as required):
List of Brands starts at 'Search'!A2
List of Materials Descriptions starts at 'Raw Data Working'!K2
Output of Brands in column 'Raw Data Working'!AP
Option Compare Text ‘Must have this at the top of the module
Option Explicit
Sub Brand_Classification()
Dim aBrands As Variant, rMaterials As Range, rResults As Range
Dim rFound As Range, blFound As Boolean, sFound As String
Dim sMaterial As String
Dim lLastRow As Long
Dim vItm As Variant
Dim iAsc As Integer, bPos As Byte
Dim b As Byte
Rem Set Array with Brands
With ThisWorkbook.Sheets("Search") 'Change as needed
lLastRow = .Columns("A:A").Cells(1 + .UsedRange.SpecialCells(xlLastCell).Row).End(xlUp).Row 'Change as needed
aBrands = .Range("A2:A" & lLastRow).Value2 'Change as needed
End With
With ThisWorkbook.Sheets("Raw Data Working") 'Change as needed
Rem Set Materials Description Range
lLastRow = .Columns("K:K").Cells(1 + .UsedRange.SpecialCells(xlLastCell).Row).End(xlUp).Row 'Change as needed
Set rMaterials = .Range("K2:K" & lLastRow) 'Change as needed
Rem Set Brand Results Range
Set rResults = .Range("AP2:AP" & lLastRow) 'Change as needed
Rem Clearing prior results
'rResults.ClearContents '}Choose one of
rResults.Value = Chr(39) '}these options
End With
Rem Search for Brands in Materials Description
For Each vItm In aBrands
If vItm <> Empty Then
With rMaterials
Set rFound = .Cells.Find(What:=vItm, After:=.Cells(.Cells.Count), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Rem Validate Value Found
If Not rFound Is Nothing Then
sFound = rFound.Address
Do
Rem Process Value Found
blFound = True
sMaterial = rFound.Value
For b = 1 To 2
Select Case b
Case 1
Rem Get Character Before Value
bPos = InStr(sMaterial, vItm)
bPos = -1 + bPos
Case 2
Rem Get Character After Value
bPos = InStr(sMaterial, vItm) + Len(vItm)
End Select
Rem Get Character
Select Case bPos
Case 0, Is > Len(sMaterial)
Case Else
Rem Validate Character
On Error Resume Next
iAsc = Asc(Mid(sMaterial, bPos, 1))
On Error GoTo 0
Select Case iAsc
Case 65 To 90, 97 To 122
blFound = False
End Select: End Select: Next
Rem Write Results
If blFound Then
With rResults.Cells(1 - rMaterials.Row + rFound.Row)
If .Value = Empty Then
.Value = vItm
Else
.Value = .Value & ", " & vItm
End If: End With: End If
Rem Search Next
Set rFound = .FindNext(After:=rFound)
If rFound.Address = sFound Then Exit Do
Loop: End If: End With: End If: Next
End Sub
Suggest to read the following pages to gain a deeper understanding of the resources used:
Do...Loop Statement,
For Each...Next Statement,
On Error Statement,
Option keyword,
Range Object (Excel),
Select Case Statement,
Variables & Constants,
With Statement,