VBA - finding unique Titles from a cell, then creating columns, then populating the data

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,

https://techcommunity.microsoft.com/t5/excel/obtain-data-from-a-cell-with-lots-of-paragraphs/m-p/3280679

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.