Automatic Splitting of cells based on example; using expanded definitions as per scripting dictionary/look up + copy pasting into next available column

Sub transform()
    Dim rg As Range, d As Object
    Dim v As Variant, s As Variant, t As Variant
    Dim i As Long, lRow As Long

    With ThisWorkbook
        Set d = CreateObject("Scripting.Dictionary")
        Set rg = .Worksheets("Key").UsedRange
        For i = 2 To rg.Rows.Count
            d.Add rg(i, 1).Value, rg(i, 2).Value
        Next i
        v = .Worksheets("original").UsedRange
        With .Worksheets("transformed")
            .UsedRange.Offset(1).Clear
            For i = LBound(v) + 1 To UBound(v)
                lRow = .Cells(.Rows.Count, 3).End(xlUp).Row + 1
                .Cells(lRow, 1) = v(i, 1)
                s = Split(v(i, 2), ";")
                For Each t In s
                    .Cells(lRow, 2) = d(Mid(t, 2, InStr(2, t, "}") - 2))
                    .Cells(lRow, 3) = Right(t, Len(t) - InStrRev(t, "}"))
                    lRow = lRow + 1
                Next t
            Next i
        End With
    End With
End Sub

Sub transform()
    Dim rg As Range, d As Object
    Dim v As Variant, s As Variant, t As Variant
    Dim i As Long, lRow As Long

    With ThisWorkbook
        Set d = CreateObject("Scripting.Dictionary") 'creates a dictionary
        Set rg = .Worksheets("Key").UsedRange 'grabs all the keys
        For i = 2 To rg.Rows.Count
            d.Add rg(i, 1).Value, rg(i, 2).Value 'places keys in dictionary
        Next i
        v = .Worksheets("original").UsedRange
        With .Worksheets("transformed")
            .UsedRange.Offset(1).Clear 'erases any existing results
            For i = LBound(v) + 1 To UBound(v)
                lRow = .Cells(.Rows.Count, 3).End(xlUp).Row + 1 'finds the next row with no data
                .Cells(lRow, 1) = v(i, 1) 'copies the name
                s = Split(v(i, 2), ";") 'separates the data in each line
                For Each t In s 'goes through each datum in the line
                    .Cells(lRow, 2) = d(Mid(t, 2, InStr(2, t, "}") - 2)) 'writes the key found in dictionary
                    .Cells(lRow, 3) = Right(t, Len(t) - InStrRev(t, "}")) 'calls out the key's number
                    lRow = lRow + 1
                Next t 'rinse and repeat
            Next i
        End With
    End With
End Sub