Sort table vertically

[Paul_Hossler]

Thank you Paul_Hossler.
Your solution helps a great deal.
Is it possible that you can make a slight adaption so that it works when the company is in a different position like in the file below.
All the rest is the same.

And there is one other thing.
The Company names can change over time.
It would be great If the names would not be in the vba but if the script could find the first row with comapny names and uses this as a template for sorting the other columns accordingly.

Thanks again many, many times.

Don't know if you still want this

Changes include

1. "Company" can be in any col, col B now
2. The (a) ... names can be anything

Option Explicit

Sub Reformat2()
    Dim ws As Worksheet
    Dim rData As Range, rCompany As Range
    Dim iCol As Long, iRow As Long, iCompanyCol As Long
    Dim aryCompanies(1 To 4) As String
    
    Set ws = ActiveSheet
    
    Set rData = Intersect(ws.UsedRange, ws.Columns(1).Resize(, 5))
    
    'have to find "Company" column
    rData.Cells(1, 1).Select
    rData.Find(What:="Company", After:=ActiveCell, LookIn:=xlFormulas2, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=True, SearchFormat:=False).Activate
    
    iCompanyCol = ActiveCell.Column
    
    
    'have to find line with all 4 companies
    For iRow = 1 To rData.Rows.Count
        With rData
            If .Cells(iRow, iCompanyCol).Value = "Company" Then
                If Application.WorksheetFunction.CountA(Range(.Cells(iRow, iCompanyCol + 1), .Cells(iRow, iCompanyCol + 4))) = 4 Then
                    'found company line with all 4
                    For iCol = 1 To 4
                        aryCompanies(iCol) = .Cells(iRow, iCompanyCol + iCol).Value
                    Next iCol
                
                    Exit For
                End If
            End If
        End With
    Next iRow
    
        
    'go down data
    For iRow = 1 To rData.Rows.Count
        With rData
            
            If .Cells(iRow, iCompanyCol).Value <> "Company" Then GoTo NextRow
            
            'since there's now data in col a, .CurrentRegion (the easy way) won't work :-(
            Set rCompany = .Cells(iRow, iCompanyCol)
            Set rCompany = Range(.Cells(iRow, iCompanyCol), .Cells(iRow, iCompanyCol).End(xlDown))
            Set rCompany = rCompany.EntireRow
            
            
            For iCol = iCompanyCol + 1 To iCompanyCol + 4
                
                Select Case iCol
                    Case iCompanyCol + 1
                        If .Cells(iRow, iCol).Value <> aryCompanies(1) Then
                            rCompany.Columns(iCol).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                            .Cells(iRow, iCol).Value = aryCompanies(1)
                        End If
                    Case iCompanyCol + 2
                        If .Cells(iRow, iCol).Value <> aryCompanies(2) Then
                            rCompany.Columns(iCol).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                            .Cells(iRow, iCol).Value = aryCompanies(2)
                        End If
                    Case iCompanyCol + 3
                        If .Cells(iRow, iCol).Value <> aryCompanies(3) Then
                            rCompany.Columns(iCol).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                            .Cells(iRow, iCol).Value = aryCompanies(3)
                        End If
                    Case iCompanyCol + 4
                        If .Cells(iRow, iCol).Value <> aryCompanies(4) Then
                            rCompany.Columns(iCol).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                            .Cells(iRow, iCol).Value = aryCompanies(4)
                        End If
                End Select
            Next iCol
        End With
NextRow:
    Next iRow

    MsgBox "Done"

End Sub

Edit -- You MAY have to change LookIn:=xlFormulas2, to just LookIn:=xlFormulas, depending on your version of Excel