Hello,
I am trying to extract unique text values from strings in a long range of cells and output the unique values from each cell in a column below the last output cell.
For example:
A1: earth metal fire, Fire
A2: sun Water Earth Sun: SUN
Output:
B1: earth
B2: metal
B3: fire
B4: sun
B5: water
B6: earth
A solution to this would be most helpful and appreciated.
Thank you!
Re: VBA Code to Extract Unique Text Values from Strings in Each Cell
Are there any other delimiters between the words other than what you have shown.
You show space, "," and ":" are there any others?
Re: VBA Code to Extract Unique Text Values from Strings in Each Cell
Yes, there could be other delimiters. The example I have shown is very simplified and in my file there could be several sentences in one cell.
Re: VBA Code to Extract Unique Text Values from Strings in Each Cell
I would need them, maybe someone else can get by without them, but I would need them.
Having a simplified example often leads to many rewrites of code so you really should prepare a better example.
Re: VBA Code to Extract Unique Text Values from Strings in Each Cell
Hi Skywriter....Sorry about posting a simplified example. I will post a real sample of the cells I'm working on tomorrow as I have already left work. Thanks for looking into this. Much appreciated!
Re: VBA Code to Extract Unique Text Values from Strings in Each Cell
Here are some real samples:
A1:
Imaging guideline not followed resulting in extra kV image being taken.
_________________
kV image x2 due to switching out therapists while imaging
A2:
2 extra images taken. 1st image: anatomy settings were not selected. 2nd image: therapists thought they were moded up on tmt fld but still had image moded up
The output is to be put into another column with only unique words listed once for each cell. Case should be non-sensitive. The output for A2 is to be placed in the cell after the output for A1.
I would also like to be able to specify in the code, any words to ignore, eg. "not","to","in","being","while","on","were","but","had",":",'.".
The column with the output for A1 would be:
imaging
guideline
followed
resulting
extra
kv
image
taken
x2
due
switching
therapists
And the output for A2 would be placed in the cell after "therapist".
Thanks so much for any help you can give me.
L.
Re: VBA Code to Extract Unique Text Values from Strings in Each Cell
You could use code like this.
You can add punctuation marks to that string as needed. (don't introduce a space)
You can also add to the WordsToIgnore array.
Sub atest()
Dim inputRange As Range, outputRange As Range
Dim inputString As String, outputString As String
Dim OutPutWords As Variant
Dim WordsToIgnore As Variant
Dim i As Long
Const Punctuation As String = ".,;:?"
WordsToIgnore = Array("the", "or", "not", "to", "in", "being", "while", "on", "were", "but", "had")
Set inputRange = Sheet1.Range("A1").CurrentRegion.Columns(1)
Set outputRange = inputRange.Offset(inputRange.Rows.Count + 1, 0)
inputString = " " & LCase(ConcatRange(inputRange)) & " "
For i = 1 To Len(Punctuation)
inputString = Replace(inputString, Mid(Punctuation, i, 1), " ")
Next i
For i = LBound(WordsToIgnore) To UBound(WordsToIgnore)
inputString = Replace(inputString, " " & LCase(WordsToIgnore(i)) & " ", " ")
Next i
inputString = WorksheetFunction.Trim(inputString)
outputString = SortDelimitedString(inputString, Delimiter:=" ", Unique:= True, Descending:= False)
OutPutWords = Split(outputString, " ")
outputRange.Resize(UBound(OutPutWords) + 1, 1) = Application.Transpose(OutPutWords)
End Sub
Function ConcatRange(aRange As Range, Optional Delimiter As String = " ") As String
Dim oneCell As Range
For Each oneCell In aRange.Cells
ConcatRange = ConcatRange & Delimiter & CStr(oneCell.Value)
Next oneCell
ConcatRange = Mid(ConcatRange, Len(Delimiter) + 1)
End Function
Function SortDelimitedString(aString As String, Optional Delimiter As String = " ", _
Optional Unique As Boolean, Optional Descending As Boolean) As String
Dim Words As Variant
Dim strLeft As String, strPivot As String, strRight As String
Dim i As Long
If aString = vbNullString Then Exit Function
Words = Split(aString, Delimiter)
strPivot = Words(0)
For i = 1 To UBound(Words)
If (Words(i) = strPivot) Then
If Not Unique Then strRight = strRight & Delimiter & Words(i)
ElseIf (Words(i) < strPivot) Xor Descending Then
strLeft = strLeft & Delimiter & Words(i)
ElseIf (strPivot < Words(i)) Xor Descending Then
strRight = strRight & Delimiter & Words(i)
End If
Next i
strLeft = Mid(strLeft, Len(Delimiter) + 1)
strRight = Mid(strRight, Len(Delimiter) + 1)
If strLeft <> vbNullString Then strPivot = SortDelimitedString(strLeft, Delimiter, Unique, Descending) & Delimiter & strPivot
If strRight <> vbNullString Then strPivot = strPivot & Delimiter & SortDelimitedString(strRight, Delimiter, Unique, Descending)
SortDelimitedString = strPivot
End FunctionRe: VBA Code to Extract Unique Text Values from Strings in Each Cell
Thank you very much for your help in this. This is great except for one thing….I think I wasn’t very clear and my output was incorrect…I apologize.
I need a list of the unique words listed only once for each cell. But if there is the same word in another cell, that word needs to be listed again.
From the previous example:
A1:
Imaging guideline not followed resulting in extra kV image being taken.
_________________
kV image x2 due to switching out therapists while imaging
A2:
2 extra images taken. 1st image: anatomy settings were not selected. 2nd image: therapists thought they were moded up on tmt fld but still had image moded up
Output:
image would be listed once for cell A1 (unique word listed only once for each cell)
image would be listed once for cell A2 (unique word listed only once for each cell)
In the output list, "image" would be listed twice.
I hope this is clear. Thank you so much for your help.
L.
Re: VBA Code to Extract Unique Text Values from Strings in Each Cell
Try
Sub atest()
Dim inputRange As Range, outputRange As Range
Dim inputString As String, outputString As String
Dim OutPutWords As Variant
Dim WordsToIgnore As Variant
Dim i As Long, oneCell as Range
Const Punctuation As String = ".,;:?"
WordsToIgnore = Array("the", "or", "not", "to", "in", "being", "while", "on", "were", "but", "had")
Set inputRange = Sheet1.Range("A1").CurrentRegion.Columns(1)
Set outputRange = inputRange.Offset(inputRange.Rows.Count + 1, 0)
For Each oneCell in inputRange.Cells
inputString = " " & LCase(CStr(oneCell)) & " "
For i = 1 To Len(Punctuation)
inputString = Replace(inputString, Mid(Punctuation, i, 1), " ")
Next i
For i = LBound(WordsToIgnore) To UBound(WordsToIgnore)
inputString = Replace(inputString, " " & LCase(WordsToIgnore(i)) & " ", " ")
Next i
inputString = WorksheetFunction.Trim(inputString)
outputString = outputString & " " & SortDelimitedString(inputString, Delimiter:=" ", Unique:= True, Descending:= False)
Next oneCell
outputString = SortDelimitedString(outputString, Delimiter:=" ", Unique:=False, Descending:= False)
OutPutWords = Split(outputString, " ")
outputRange.Resize(UBound(OutPutWords) + 1, 1) = Application.Transpose(OutPutWords)
End SubRe: VBA Code to Extract Unique Text Values from Strings in Each Cell
Thanks for the code.
I'm getting a "compile error: Sub or Function not defined" for SortDelimitedString.
Re: VBA Code to Extract Unique Text Values from Strings in Each Cell
The code in post #9 is a replacement for the atest sub in post #7.
The function SortDelimitedString from post #7 is also needed.
Re: VBA Code to Extract Unique Text Values from Strings in Each Cell
Thank you very much Mike. It worked very well. I’m a real novice in VBA and am learning as I go. Thanks again.
Don’t have an account yet? Register yourself now and be a part of our community!