VBA code required
Imagine I had a cell in A column with the following data below
cell A2 has name=Jake||Last=Smith||species=human||Language=en
cell A3 has name=Steve||Language=en
cell A4 has Language=en||gender=male||power=high
I require a VBA code, that will provide me a list of all unique ||string= where the string is the unique values above.
Meaning the cells in columns wise B1, C1, D1, E1, F1, G1
Will be
B1 has name=
C1 has last=
D1 has species=
E1 has language=
F1 has gender=
G1 has power=
Input
Output
Input Data to copy-paste
Metrics
name=Jake||Last=Smith||species=human||Language=en
name=Steve||Language=en
Language=en||gender=male||power=high
I tried using ChatGPT, and got the subscript not found Error
Sub ExtractUniqueStrings()
Dim rng As Range
Dim cell As Range
Dim str As String
Dim arr() As String
Dim uniqueArr() As String
Dim unique As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Set rng = Range("A2:A4")
' loop through each cell in the range
For Each cell In rng
str = cell.Value
arr = Split(str, "||")
' loop through each element in the array
For i = 0 To UBound(arr)
unique = Split(arr(i), "=")(0)
' check if the unique string already exists in the uniqueArr
For j = 0 To UBound(uniqueArr)
If unique = uniqueArr(j) Then
Exit For
End If
Next j
' if the unique string does not exist in the uniqueArr, add it
If j > UBound(uniqueArr) Then
ReDim Preserve uniqueArr(k)
uniqueArr(k) = unique
k = k + 1
End If
Next i
Next cell
' output the unique strings to the next available column
For i = 0 To UBound(uniqueArr)
Cells(1, i + 2).Value = uniqueArr(i) & "="
Next i
End Sub
and
Sub OrganizeValues()
Dim rng As Range
Dim cell As Range
Dim str As String
Dim arr() As String
Dim uniqueArr() As String
Dim unique As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim col As Integer
Set rng = Range("A2:A4")
' loop through each cell in the range
For Each cell In rng
str = cell.Value
arr = Split(str, "||")
' loop through each element in the array
For i = 0 To UBound(arr)
unique = Split(arr(i), "=")(0)
value = Split(arr(i), "=")(1)
' check if the unique string already exists in the uniqueArr
For j = 0 To UBound(uniqueArr)
If unique = uniqueArr(j) Then
Exit For
End If
Next j
' if the unique string does not exist in the uniqueArr, add it
If j > UBound(uniqueArr) Then
ReDim Preserve uniqueArr(k)
uniqueArr(k) = unique
k = k + 1
End If
Next i
Next cell
' loop through each cell in the range again
For Each cell In rng
str = cell.Value
arr = Split(str, "||")
' loop through each element in the array
For i = 0 To UBound(arr)
unique = Split(arr(i), "=")(0)
value = Split(arr(i), "=")(1)
' check if the unique string exists in the uniqueArr
For j = 0 To UBound(uniqueArr)
If unique = uniqueArr(j) Then
' find the corresponding column
col = j + 2
Exit For
End If
Next j
' output the value to the corresponding column
Cells(cell.Row, col).Value = value
Next i
Next cell
End Sub
I do have a working UDF, but it works as such,
Convert the delimiter || to newline using replace Cntrl+J
First, use replace || to cntl+J
then in the cell, you need to find the value.
=ExtractPartsF($AB$1, y2)
=ExtractPartsF(Keyword_to_search, Where to search it in)
' This is Simple
'
' It's ExtractParts(The absolute value of where the Keyword to match is, Location of Transcript/coversation)
' Example, ExtractParts($AC$1, AA2) where $AC$1 is a cell were the IDK Amelia's response is stored/entered. AA2 is the cell with the clean transcript.
'
' This code will provide The exact sentence where the Keyword was found (this Keyword is in $AC$1)
'
' Caution If blank, the text is still a single newline char, so counting newline, means it'll give 1 for blanks.
Function ExtractPartsF(Keyword As String, Txt As String) As String
Dim strLines() As String
Dim j As Long
Dim i As Long
Dim n As Long
Dim strReturn() As String
strLines = Split(Txt, vbLf)
For j = 0 To UBound(strLines)
If InStr(1, strLines(j), Keyword, vbTextCompare) > 0 Then
n = n + 1
ReDim Preserve strReturn(1 To n)
strReturn(n) = strLines(j)
End If
Next j
ExtractPartsF = Join(strReturn, vbLf)
End Function
From my previous post
Obtain data from a cell with lots of paragraphs - Microsoft Tech Community
aka,
I need help getting the output from the input given.
Size can vary from A column being 10-5,000 rows.
So I'd like to avoid using a re-dim, except for Titles.
