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