VBA Transpose

This version will create and populate the named ranges in one go which will hopefully improve the speed. It would be faster still if there were not a few thousand rows on Sheet 1 containing just "_".

Sub TransposeRange()
    Dim OutRange              As Range
    Dim x As Long, y As Long
    Dim sKey As String
    Dim maxCount As Long
    Dim data, dic, keys, items, dataout()

    Application.ScreenUpdating = False
    data = Sheet1.Range("A2:E" & Cells(Rows.Count, "A").End(xlUp).Row).Value2

    Set dic = CreateObject("scripting.dictionary")
    Set OutRange = Sheet2.Range("B2")

    For x = 1 To UBound(data, 1)
        sKey = Trim$(data(x, 1)) & Chr(0) & Trim$(data(x, 2))
        If Not dic.exists(sKey) Then dic.Add sKey, CreateObject("Scripting.Dictionary")
        dic(sKey).Add x, Array(data(x, 4), data(x, 5))
        If dic(sKey).Count > maxCount Then maxCount = dic(sKey).Count
    Next

    ReDim dataout(1 To maxCount + 1, 1 To dic.Count * 3)
    keys = dic.keys
    items = dic.items
    For x = LBound(keys) To UBound(keys)
        dataout(1, x * 3 + 1) = Split(keys(x), Chr(0))(0)
        dataout(1, x * 3 + 2) = Split(keys(x), Chr(0))(1)
        For y = 1 To items(x).Count
            dataout(1 + y, x * 3 + 1) = items(x).items()(y - 1)(0)
            dataout(1 + y, x * 3 + 2) = items(x).items()(y - 1)(1)
        Next y
    Next


    OutRange.Resize(UBound(dataout, 1), UBound(dataout, 2)).Value2 = dataout

    For x = 1 To UBound(keys)
        OutRange.Offset(0, (x - 1) * 3).Resize(maxCount, 2).Name = "" & validName(Split(keys(x - 1), Chr(0))(0))
    Next

End Sub
Function validName(ByVal sText As String) As String
    Dim n As Long
    Dim bChars() As Byte
    bChars = sText
    If UCase$(sText) Like "*[!A-Z0-9._]*" Then
        For n = 0 To UBound(bChars) - 1 Step 2
            Select Case bChars(n)
                Case 46, 48 To 57, 65 To 90, 95
                    ' valid character: _ . number or letter
                Case Else
                    ' convert to underscore
                    bChars(n) = 95
            End Select
        Next n
    End If
    validName = bChars
End Function