Transpose Tables arranged horizontally to vertically

[RINCONPAUL]

I need to transpose groups of table data displayed horizontally and stack them vertically keeping common col A,B,C,D reference. The attached example shows sheet "Display1" as the current situation and sheet "Display2" the desired situation.
The real life scenario differs in that there are 14 tables horizontally, each with 12 headers. Some data in cells of tables will be blank! The row count for each "Event" varies and the number off.

Thanks

[rlv]

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

[MickG]

Based on your date try this:-
If your tables Have 12 Headers each, you will need to change "Step 6 " to "Step 12" accordingly

Sub  Tables()
Dim Rng As Range, Dn As Range, n As Long, Dic As Object, R As Range, Ac As Long
Dim lst As Long, K As Variant, c As Long

With Sheets("Display1")
    Set Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    lst = .Cells("1", Columns.Count).End(xlToLeft).Column
End With
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    For Each Dn In Rng
        If Not Dic.Exists(Dn.Value) Then
            Dic.Add Dn.Value, Dn
        Else
            Set Dic(Dn.Value) = Union(Dic(Dn.Value), Dn)
        End If
    Next



 c = 2
With Sheets("Display2")
For Each K In Dic.keys
   Set R = Dic(K).Resize(, 4)
        .Range("A1:J1").Value = Array("Event", "Total Matched", "Countdown", "Race Status", "Name", "Back", "Lay", "Vol", "Rank", "# Runners")
            For Ac = 5 To lst Step 6
              .Cells(c, 1).Resize(Dic(K).Count, 4).Value = R.Value
              .Cells(c, 5).Resize(Dic(K).Count, 6).Value = R(, Ac).Resize(, 6).Value
               c = c + Dic(K).Count
            Next Ac
Next K
With .Range("A1:J" & c)
    .Borders.Weight = 2
    .Columns.AutoFit
End With
 End With
End Sub

[rlv]

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