Get the value between the parentheses, multiple matches in one string - vba

My spreadsheet has a column with value like this string:
some text (text1) some test (text2) (text1)
How do I get all values between parentheses? The result I am looking for is:
text1, text2
Even if text1, text2... testn is present in the cell multiple times, I need it in the result only once.
I found a function GetParen here: Get the value between the brackets
It is helpful, but it gives the fist available value in the parentheses and ignores the rest.

It seems unwieldy to have one User Defined Function for individual entries and another for a collective result of all entries.
Paste the following into a standard module code sheet.
Function getBracketedText(str As String, _
Optional pos As Integer = 0, _
Optional delim As String = ", ", _
Optional dupes As Boolean = False)
Dim tmp As String, txt As String, a As Long, b As Long, p As Long, arr() As Variant
tmp = str
ReDim arr(1 To 1)
For b = 1 To (Len(tmp) - Len(Replace(tmp, Chr(40), vbNullString)))
p = InStr(p + 1, tmp, Chr(40))
txt = Trim(Mid(tmp, p + 1, InStr(p + 1, tmp, Chr(41)) - (p + 1)))
If UBound(Filter(arr, txt, True)) < 0 Or dupes Then '<~~ check for duplicates within the array
a = a + 1
ReDim Preserve arr(1 To a)
arr(UBound(arr)) = txt
End If
Next b
If CBool(pos) Then
getBracketedText = arr(pos)
Else
getBracketedText = Join(arr, delim)
End If
End Function
Use like any other native worksheet function. There are optional parameters to retrieve an individual element or a collection as well as changing the default <comma><space> delimiter.
    

This code works for me:
Sub takingTheText()
Dim iniP 'first parenthesis
Dim endP 'last parentehis
Dim myText 'the text
Dim txtLen
Dim i
Dim tmp
Dim j
myText = Range("A1").Value
txtLen = Len(myText)
j = 0
Do 'Loop in the text
i = i + 1 'a counter
iniP = InStr(1, myText, "(", 1) 'found the first occurence of the (
endP = InStr(1, myText, ")", 1) 'same as above
tmp = tmp & Right(Left(myText, i), 1) 'take the text garbage text
If i = iniP Then 'here comes the work
j = j + 1 'here take the cell index
myText = Replace(myText, tmp, "") 'remove the garbage text in front the first (
tmp = Left(myText, endP - iniP - 1) 'reuse the var to store the usefull text
Cells(1, 2).Value = Cells(1, 2).Value & Chr(10) & tmp 'store in the cell B1
'If you want to stored in separated cells use the below code
'Cells(j, 2).Value = tmp
myText = Replace(myText, tmp & ")", "", 1, 1) ' remove the garbage text from the main text
tmp = Empty 'empty the var
i = 0 'reset the main counter
End If
Loop While endP <> 0
End Sub
Result:
Please check and tellme if is ok.
Edit#1
Cells(1, 2).Value = Cells(1, 2).Value & Chr(10) & tmp this code store the text in separated lines inside the same cell, may be you want to use spaces between the resulting text because of chr(10) (also you can use chr(13)), then you can use Cells(1, 2).Value = Cells(1, 2).Value & " " & tmp, or use any other character instead the string inside the & symbols

Related

Vba separate multiple dates in one cell

I am trying to separate multiple dates from one cell into multiple cells containing one date in a transposed area and then paste them back over the original area as separate entries.
An example cell might have dates stored like 10/1110/1110/13 or 10/310/310/410/5.
The second scenario is what is causing the error as there is no leading zero for single digit days like 10/3, for example.
Ideally, the code would separate the dates into separate cells like: 10/11,10/11,10/13 and 10/3,10/4,10/5. When single digits days are present ,however, it comes out completely jumbled up and inaccurate.
Admittedly, I had help from another coworker with this code who is on vacation currently, which is why I am having such trouble understanding this. Is there something I could change to account for single digit days or should I approach this process differently?
Thanks!
'separate column J by "/" and store in transpose area
dim h as variant
dim i as variant
dim j as variant
dim counter as variant
dim stringcheck as variant
dim strInput as variant
dim strCurrent as variant
strInput = Cells(j, 10)
h = 0
For counter = 1 To Len(strInput) - 2
stringcheck = InStr(strInput, "/")
Debug.Print j & stringcheck
If stringcheck <> 0 Then
If Mid(strInput, counter, 1) = "/" Then
Cells(17, i + h) = strCurrent & Mid(strInput, counter, 3)
counter = counter + 2
h = h + 1
strCurrent = vbNullString
Else
Cells(17, i + h) = Cells(j, 10)
strCurrent = strCurrent & Mid(strInput, counter, 1)
End If
'else just paste the value
Else
Cells(17, i) = strInput
End If
Next counter
If all of the months within one cell's mashed up dates can be reasonably assumed to be the same then that could be used as a delimiter to split the mash-up and reassemble it.
Function splitMashUp(str As String, _
Optional splitchr As String = "/", _
Optional delim As String = ", ")
Dim i As Long, tmp As Variant
tmp = Split(str, Left(str, InStr(1, str, splitchr)))
For i = LBound(tmp) + 1 To UBound(tmp)
tmp(i) = Left(str, InStr(1, str, splitchr)) & tmp(i)
Next i
splitMashUp = Mid(Join(tmp, delim), Len(delim) + 1)
End Function

VBA how to fix errors for strings starts with special character

I am fairly new in VBA, i am working on a project, there's small problem i am facing. I am taking newLastCmtTypeCol, newLastCmtCol, newLastNoteCol, oldLastCmtTypeCol, oldLastCmtCol, oldLastNoteCol as strings and i am only calling them in this part of code. so the error happend when one of the string start with a special character. I am taking input from sheet with alot of data. there's absolutely no way i can go through all of that data all the time. I just wanna ignore the strings start with starts with special character, so i wouldnt see any error.Here is the part of the code.
Dim newLastCmtTypeCol As String
Dim newLastCmtCol As String
Dim newLastNoteCol As String
Dim oldLastCmtTypeCol As String
Dim oldLastCmtCol As String
Dim oldLastNoteCol As String
newLastCmtTypeCol = "N"
newLastCmtCol = "O"
newLastNoteCol = "P"
oldLastCmtTypeCol = "Q"
oldLastCmtCol = "R"
oldLastNoteCol = "S"
For j = 0 To indexNew(i, 4)
If (StrComp(ws1.Range(newLastCmtTypeCol & i + j), ws1.Range(oldLastCmtTypeCol & i + j)) = 0) And _
(StrComp(ws1.Range(newLastCmtCol & i + j), ws1.Range(oldLastCmtCol & i + j)) = 0) And _
(StrComp(ws1.Range(newLastNoteCol & i + j), ws1.Range(oldLastNoteCol & i + j)) = 0) And categoryCode = 1 Then
categoryCode = 1
ElseIf IsEmpty(ws1.Range(oldLastCmtTypeCol & i + j)) And IsEmpty(ws1.Range(oldLastCmtCol & i + j)) And IsEmpty(ws1.Range(oldLastNoteCol & i + j)) Then
categoryCode = 3
Exit For
Else
categoryCode = 2
End If
Next j
Any solution?
Your issues seems to be with cells containing an error, not special characters.
If so, you probably want to filter out such cells.
You could use IsError to wrap your code, e.g.
If (Not (IsError(ws1.Range(newLastCmtTypeCol & i + j))) and _
Not (IsError(ws1.Range(oldLastCmtTypeCol & i + j))) and _
... _
) Then
Then you would be able to compare anything else.
You may want to use conversions between String and numbers, if needed.
Public Function DelInvalidCharacters(InputString As String) As String
Dim ModString As String, InvalidChars As String, Char As String
Dim i As Integer
InvalidChars = "\/:*?""<>|';#,()%&$+- "
ModString = vbNullString
For i = 1 To Len(InputString)
Char = Mid(InputString, i, 1)
If InStr(1, InvalidChars, Char) = 0 Then
ModString = ModString & Char
End If
Next i
DelInvalidCharacters = ModString
End Function
Just call this function for each variable you want to strip bad characters out of
Calling it like this
Dim this As String
this = "*this"
this = DelInvalidCharacters(this)

Searching for several exact substrings in one String

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!
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.
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
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,

VBA/UDF, Vlookup to return multiple values]

I am trying to lookup a value and return multiple values (whether it be in the same cell or spread out horizontally pasted in different columns)I have tried the following UDF and continue to get #VALUE as result.
Option Explicit
Function LookupCSVResults(lookupValue As Variant, lookupRange As Range, resultsRange As Range) As String
Dim s As String 'Results placeholder
Dim sTmp As String 'Cell value placeholder
Dim r As Long 'Row
Dim c As Long 'Column
Const strDelimiter = "|||" 'Makes InStr more robust
s = strDelimiter
For r = 1 To lookupRange.Rows.Count
For c = 1 To lookupRange.Columns.Count
If lookupRange.Cells(r, c).Value = lookupValue Then
'I know it's weird to use offset but it works even if the two ranges
'are of different sizes and it's the same way that SUMIF works
sTmp = resultsRange.Offset(r - 1, c - 1).Cells(1, 1).Value
If InStr(1, s, strDelimiter & sTmp & strDelimiter) = 0 Then
s = s & sTmp & strDelimiter
End If
End If
Next
Next
'Now make it look like CSV
s = Replace(s, strDelimiter, ",")
If Left(s, 1) = "," Then s = Mid(s, 2)
If Right(s, 1) = "," Then s = Left(s, Len(s) - 1)
LookupCSVResults = s 'Return the function
End Function
Formula in cell =LookupCSVResults(Lookup Value, Col of Lookup Value, Col of Return Value)
Can anyone help trouble shoot this or have another UDF that will provide similar result? Thanks.

Trying to extract data from curly braces but not working

I need to sync up the values in the curly braces {} found in column C and put them against the user id in column F as seen below.
E.g. on the Emails sheet
becomes this on a new sheet
Sub CopyConditional()
Dim wshS As Worksheet
Dim WhichName As String
Set wshS = ActiveWorkbook.Sheets("Emails")
WhichName = "NewSheet"
Const NameCol = "C"
Const FirstRow = 1
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim wshT As Worksheet
Dim cpt As String
Dim user As String
Dim computers() As String
Dim computer As String
On Error Resume Next
Set wshT = Worksheets(WhichName)
If wshT Is Nothing Then
Set wshT = Worksheets.Add(After:=wshS)
wshT.Name = WhichName
End If
On Error GoTo 0
If wshT.Cells(1, NameCol).value = "" Then
TrgRow = 1
Else
TrgRow = wshT.Cells(wshT.Rows.Count, NameCol).End(xlUp).Row + 1
End If
LastRow = wshS.Cells(wshS.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
cpt = wshS.Range("C" & SrcRow).value
user = wshS.Range("F" & SrcRow).value
If InStr(cpt, ":") Then
cpt = Mid(cpt, InStr(1, cpt, ":") + 1, Len(cpt))
End If
If InStr(cpt, ";") Then
computers = Split(cpt, ";")
For i = 0 To UBound(computers)
If computers(i) <> "" Then
wshT.Range("A" & TrgRow).value = user
wshT.Range("B" & TrgRow).value = Mid(Left(computers(i), Len(computers(i)) - 1), 2)
TrgRow = TrgRow + 1
End If
Next
Else
computer = cpt
If computer <> "" Then
wshT.Range("A" & TrgRow).value = user
wshT.Range("B" & TrgRow).value = Mid(Left(computer, Len(computer) - 1), 2)
TrgRow = TrgRow + 1
End If
End If
Next SrcRow
End Sub
I managed to resolve it with the above code but there are 3 niggling issues:
1) The first curly brace is always copied, how do I omit this so something like {Computer1 looks like Computer 1
2) Where there are two computers in a row, then the output looks something like this:
when it should really be split into two different rows i.e.
User 1 | Computer 1
User 1 | Computer 2
3) If there is text after the last curly brace with text in it e.g. {Computer1};{Computer2};Request submitted then that text is added as a new row, I don't want this, I want it to be omitted e.g.
should just be:
User 1 | Computer 1
User 1 | Computer 2
How do I go about rectifying these issues?
Try this:
Sub Collapse()
Dim uRng As Range, cel As Range
Dim comps As Variant, comp As Variant, r As Variant, v As Variant
Dim d As Dictionary '~~> Early bind, for Late bind use commented line
'Dim d As Object
Dim a As String
With Sheet1 '~~> Sheet that contains your data
Set uRng = .Range("F1", .Range("F" & .Rows.Count).End(xlUp))
End With
Set d = CreateObject("Scripting.Dictionary")
With d
For Each cel In uRng
a = Replace(cel.Offset(0, -3), "{", "}")
comps = Split(a, "}")
Debug.Print UBound(comps)
For Each comp In comps
If InStr(comp, "Computer") <> 0 _
And Len(Trim(comp)) <= 10 Then '~~> I assumed max Comp# is 99
If Not .Exists(cel) Then
.Add cel, comp
Else
If IsArray(.Item(cel)) Then
r = .Item(cel)
ReDim Preserve r(UBound(r) + 1)
r(UBound(r)) = comp
.Item(cel) = r
Else
r = Array(.Item(cel), comp)
.Item(cel) = r
End If
End If
End If
Next
Next
End With
For Each v In d.Keys
With Sheet2 '~~> sheet you want to write your data to
If IsArray(d.Item(v)) Then
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) _
.Resize(UBound(d.Item(v)) + 1) = v
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) _
.Resize(UBound(d.Item(v)) + 1) = Application.Transpose(d.Item(v))
Else
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = v
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) = d.Item(v)
End If
End With
Next
Set d = Nothing
End Sub
Above code uses Replace and Split Function to pass your string to array.
a = Replace(cel.Offset(0, -3), "{", "}") '~~> standardize delimiter
comps = Split(a, "}") '~~> split using standard delimiter
Then information are passed to dictionary object using User as key and computers as items.
We filter the items passed to dictionary using Instr and Len Function
If InStr(comp, "Computer") <> 0 _
And Len(Trim(comp)) <= 10 Then
As I've commented, I assumed your max computer number is 99.
Else change 10 to whatever length you need to check.
Finally we return the dictionary information to the target worksheet.
Note: You need to add reference to Microsoft Scripting Runtime if you prefer early bind
Result: I tried it on a small sample data patterned on how I see it in you SS.
So assuming you have this data in Sheet1:
Will output data in Sheet2 like this:
I use a custom parse function for this type of operation:
Sub CopyConditional()
' some detail left out
Dim iRow&, Usern$, Computer$, Computers$
For iRow = ' firstrow To lastrow
Usern = Sheets("Emails").Cells(iRow, "F")
Computers = Sheets("Emails").Cells(iRow, "C")
Do
Computer = zParse(Computers) ' gets one computer
If Computer = "" Then Exit Do
' Store Computer and Usern
Loop
Next iRow
End Sub
Function zParse$(Haystack$) ' find all {..}
Static iPosL& '
Dim iPosR&
If iPosL = 0 Then iPosL = 1
iPosL = InStr(iPosL, Haystack, "{") ' Left
If iPosL = 0 Then Exit Function ' no more
iPosR = InStr(iPosL, Haystack, "}") ' Right
If iPosR = 0 Then MsgBox "No matching }": Stop
zParse = Mid$(Haystack, iPosL + 1, iPosR - iPosL - 1)
iPosL = iPosR
End Function
1) Use the Mid function to drop the first character:
str = "{Computer1"
str = Mid(str,2)
now str = "Computer1"
2) You can use the Split function to separate these out and combine with the Mid function above
str = "{Computer1}{Computer2}"
splt = Split(str,"}")
for a = 0 to Ubound(splt)
result = Mid(splt(a),2)
next a
3) Add a conditional statement to the above loop
str = "{Computer1}{Computer2}"
splt = Split(str,"}")
for a = 0 to Ubound(splt)
if Left(splt(a),1) = "{" then result = Mid(splt(a),2)
next a
Use this loop and send each result to the desired cell (in the for-next loop) and you should be good to go.