I forgot to sort the transposed data:
Sub DoSomethingX() Dim WB As Workbook
Dim WS As Worksheet, NewWS As Worksheet
Dim RangeOfCells As Range, rngB1 As Range, rngB2 As Range
Dim I As Long, CA() As Long
Set WB = ThisWorkbook
Set WS = WB.Worksheets("Display1")
Set NewWS = WB.Worksheets("Display2")
NewWS.Cells.Clear
Set RangeOfCells = Application.Intersect(WS.UsedRange, WS.Range("A1").EntireRow)
ReDim CA(100)
For Each rngB1 In RangeOfCells
If rngB1.Value = "Name" Then
CA(I) = rngB1.Column
I = I + 1
End If
Next rngB1
ReDim Preserve CA(I - 1)
With NewWS
Set rngB1 = Application.Intersect(WS.UsedRange, WS.Range("A1").Resize(1, CA(0) - 1).EntireColumn)
rngB1.Copy
.Range("A1").PasteSpecial (xlPasteValues)
.Range("A1").PasteSpecial (xlPasteFormats)
Set rngB1 = .UsedRange.Offset(1, 0).Resize(rngB1.Rows.Count - 1)
For I = 0 To UBound(CA)
Set rngB2 = Application.Intersect(WS.UsedRange, WS.Range("A1").Offset(0, CA(I) - 1).Resize(1, 6).EntireColumn)
If I > 0 Then
rngB1.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
Set rngB2 = rngB2.Offset(1, 0).Resize(rngB2.Rows.Count - 1)
rngB2.Copy .Cells(.Rows.Count, 5).End(xlUp).Offset(1)
Else
rngB2.Copy .Cells(.Rows.Count, 5).End(xlUp)
End If
Next I
With .UsedRange
.Sort Key1:=.Columns(1), Order1:=xlAscending, Key2:=.Columns(5), Order2:=xlAscending, Header:=xlYes
End With
End With
End Sub