Sub DoSomething()
    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
    End With
End Sub