Option Explicit

Sub SelectionListToMatrix()
    ListToMatrix Selection, Selection.Cells(1, 3)
End Sub

Sub ListToMatrix(rIn As Range, rOut As Range)
    Dim arr As Variant
    arr = rIn
    
    Dim dicY As Object
    Set dicY = CreateObject("Scripting.Dictionary")
    
    Dim dicX As Object
    Set dicX = CreateObject("Scripting.Dictionary")
    
    Dim brr As Variant
    Dim crr As Variant
    Dim y As Long
    Dim u As Long
    Dim x As Integer
    Dim step As Byte
    For step = 1 To 2
        For y = 1 To UBound(arr, 1)
            If arr(y, 1) <> "" Then
                brr = Split(arr(y, 1), "|")
                If UBound(brr) >= 2 Then
                    Select Case step
                    Case 1
                        If Not dicY.Exists(brr(0)) Then dicY.Item(brr(0)) = dicY.Count + 1
                        If Not dicX.Exists(brr(1)) Then dicX.Item(brr(1)) = dicX.Count + 1
                    Case 2
                        u = dicY.Item(brr(0)) + 1
                        x = dicX.Item(brr(1)) + 1
                        crr(u, 1) = brr(0)
                        crr(1, x) = brr(1)
                        crr(u, x) = brr(2)
                    End Select
                End If
            End If
        Next
        Select Case step
        Case 1
            ReDim crr(1 To dicY.Count + 1, 1 To dicX.Count + 1)
        Case 2
            rOut.Resize(UBound(crr, 1), UBound(crr, 2)) = crr
        End Select
    Next
End Sub