Rearrange Table and Column

[LambVBA]

I'm having difficulty reorganizing a set of tables and their columns within. I currently have close to 14K rows of data. As simple as it sounds, I cannot seem to find a fix to go from its vertical layout to a horizontal. Your help would be much appreciated. Below is an example of what my data currently looks like and the next example is what I hope to achieve. Needless to say I made the data rather generic in the examples.
[TABLE="class: grid, width: 238"]
<tbody>[TR]
[TD="align: center"]table_name[/TD]
[TD="align: center"]column_name[/TD]
[/TR]
[TR]
[TD="align: center"]STS[/TD]
[TD="align: center"]STS Column 1[/TD]
[/TR]
[TR]
[TD="align: center"]STS[/TD]
[TD="align: center"]STS Column 2[/TD]
[/TR]
[TR]
[TD="align: center"]STS[/TD]
[TD="align: center"]STS Column 3[/TD]
[/TR]
[TR]
[TD="align: center"]STS[/TD]
[TD="align: center"]STS Column 4[/TD]
[/TR]
[TR]
[TD="align: center"]STS[/TD]
[TD="align: center"]STS Column 5[/TD]
[/TR]
[TR]
[TD="align: center"]STS[/TD]
[TD="align: center"]STS Column 6[/TD]
[/TR]
[TR]
[TD="align: center"]ADJ[/TD]
[TD="align: center"]ADJ Column 1[/TD]
[/TR]
[TR]
[TD="align: center"]ADJ[/TD]
[TD="align: center"]ADJ Column 2[/TD]
[/TR]
[TR]
[TD="align: center"]ADJ[/TD]
[TD="align: center"]ADJ Column 3[/TD]
[/TR]
[TR]
[TD="align: center"]ADJ[/TD]
[TD="align: center"]ADJ Column 4[/TD]
[/TR]
[TR]
[TD="align: center"]ADJ[/TD]
[TD="align: center"]ADJ Column 5[/TD]
[/TR]
[TR]
[TD="align: center"]ADR[/TD]
[TD="align: center"]ADR Column 1[/TD]
[/TR]
[TR]
[TD="align: center"]ADR[/TD]
[TD="align: center"]ADR Column 2[/TD]
[/TR]
[TR]
[TD="align: center"]ADR[/TD]
[TD="align: center"]ADR Column 3[/TD]
[/TR]
[TR]
[TD="align: center"]ADR[/TD]
[TD="align: center"]ADR Column 4[/TD]
[/TR]
[TR]
[TD="align: center"]ADR[/TD]
[TD="align: center"]ADR Column 5[/TD]
[/TR]
[TR]
[TD="align: center"]ADR[/TD]
[TD="align: center"]ADR Column 6[/TD]
[/TR]
[TR]
[TD="align: center"]ADR[/TD]
[TD="align: center"]ADR Column 7[/TD]
[/TR]
</tbody>[/TABLE]

Hopeful Outcome
[TABLE="class: grid, width: 357"]
<tbody>[TR]
[TD="align: center"]STS[/TD]
[TD="align: center"]ADJ[/TD]
[TD="align: center"]ADR[/TD]
[/TR]
[TR]
[TD="align: center"]STS Column 1[/TD]
[TD="align: center"]ADJ Column 1[/TD]
[TD="align: center"]ADR Column 1[/TD]
[/TR]
[TR]
[TD="align: center"]STS Column 2[/TD]
[TD="align: center"]ADJ Column 2[/TD]
[TD="align: center"]ADR Column 2[/TD]
[/TR]
[TR]
[TD="align: center"]STS Column 3[/TD]
[TD="align: center"]ADJ Column 3[/TD]
[TD="align: center"]ADR Column 3[/TD]
[/TR]
[TR]
[TD="align: center"]STS Column 4[/TD]
[TD="align: center"]ADJ Column 4[/TD]
[TD="align: center"]ADR Column 4[/TD]
[/TR]
[TR]
[TD="align: center"]STS Column 5[/TD]
[TD="align: center"]ADJ Column 5[/TD]
[TD="align: center"]ADR Column 5[/TD]
[/TR]
[TR]
[TD="align: center"]STS Column 6[/TD]
[TD="align: center"][/TD]
[TD="align: center"]ADR Column 6[/TD]
[/TR]
[TR]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"]ADR Column 7[/TD]
[/TR]
</tbody>[/TABLE]

 

[Peter_SSs]

See if this is what you want.

Sub Rearrange()
  Dim aColVals
  Dim i As Long
  
  Const sColVals As String = "STS,ADJ,ADR"
  
  aColVals = Split(sColVals, ",")
  Application.ScreenUpdating = False
  With Range("A1", Range("B" & Rows.Count).End(xlUp))
    For i = 0 To UBound(aColVals)
      .AutoFilter Field:=1, Criteria1:=aColVals(i)
      .Columns(2).Copy Destination:=Range("E1").Offset(, i)
    Next i
    .Parent.AutoFilterMode = False
  End With
  Range("E1").Resize(, 3).Value = aColVals
  Application.ScreenUpdating = True
End Sub

Starting with columns A:B below, the code has produced columns E:G

Excel Workbook
	A	B	C	D	E	F	G
1	table_name	column_name			STS	ADJ	ADR
2	STS	STS Column 1			STS Column 1	ADJ Column 1	ADR Column 1
3	STS	STS Column 2			STS Column 2	ADJ Column 2	ADR Column 2
4	STS	STS Column 3			STS Column 3	ADJ Column 3	ADR Column 3
5	STS	STS Column 4			STS Column 4	ADJ Column 4	ADR Column 4
6	STS	STS Column 5			STS Column 5	ADJ Column 5	ADR Column 5
7	STS	STS Column 6			STS Column 6		ADR Column 6
8	ADJ	ADJ Column 1					ADR Column 7
9	ADJ	ADJ Column 2
10	ADJ	ADJ Column 3
11	ADJ	ADJ Column 4
12	ADJ	ADJ Column 5
13	ADR	ADR Column 1
14	ADR	ADR Column 2
15	ADR	ADR Column 3
16	ADR	ADR Column 4
17	ADR	ADR Column 5
18	ADR	ADR Column 6
19	ADR	ADR Column 7
20
Rearrange

 

[LambVBA]

This code does work, but is there a way to pickup from column A what the table name should be? There are over 900 distinct table headers, not just the 3 (STS, ADJ, ADR).

 

[Peter_SSs]

This code does work, but is there a way to pickup from column A what the table name should be? There are over 900 distinct table headers, not just the 3 (STS, ADJ, ADR).

That wasn't clear to start with but try this version.

Sub RearrangeV2()
  Dim aColVals
  Dim i As Long

  Application.ScreenUpdating = False
  With Range("A1", Range("A" & Rows.Count).End(xlUp))
    .AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("E1"), Unique:=True
    aColVals = Range("E2", Range("E" & Rows.Count).End(xlUp)).Value
    Columns("E").ClearContents
    With .Resize(, 2)
      For i = 1 To UBound(aColVals, 1)
        .AutoFilter Field:=1, Criteria1:=aColVals(i, 1)
        .Columns(2).Copy Destination:=Range("E1").Offset(, i - 1)
        Range("E1").Offset(, i - 1).Value = aColVals(i, 1)
      Next i
    End With
    .Parent.AutoFilterMode = False
  End With
  Application.ScreenUpdating = True
End Sub

 

[LambVBA]

Peter, thank you so much. Brilliant! Works flawlessly.

 

[Peter_SSs]

Good news!