Printable View
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
Code: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
Based on your date try this:-
If your tables Have 12 Headers each, you will need to change "Step 6 " to "Step 12" accordingly
Code: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
I forgot to sort the transposed data:
Code: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