Sort table vertically

[Sinlink]

Hello Community,
I have attached an Excel spreadsheet where company data is available.
Not all companies have data in all columns as the 'Before' Sheet shows.
Since I want to further process the sheets, I need a uniform structure of the data.

I would like to name the row by input box or at a designated spot in the Code that shows the order of the companies that I would need.

The goal is to list the company names one below the other, and write the missing ones in the columns without data or with zeros.
As a Result the companies should then be listet uniformly under each other as shown in the sheet 'After' even if the companies then have no data.

The sheets can become very long. I have only attached an excerpt in the Excel sheet.

I am not stuck on this code.
Feel free to change it or discard it.

I am a complete beginner in VBA programming and therefore do not know what is wrong with the code.
I hope you can help me, for which I am very grateful.

Here is the Code:

Sub Company_names_in_Table_Sort_Interpretive()
  Dim a As Range, b As Variant, c As Variant, d As Variant, e As Variant
  Dim i As Long, j As Long, lc As Long, lr As Long, cols As Long, n As Long
  '
  'Fill headings
  lc = ActiveSheet.Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
  d = Range("A1", Cells(Range("A" & Rows.Count).End(3).Row, lc)).Value2
  For i = 1 To UBound(d, 1)
    If d(i, UBound(d, 2)) <> "" Then
      lr = i
      Exit For
    End If
  Next
  cols = lc - 2
  ReDim e(1 To 1, 1 To cols)
  For i = 1 To cols
    e(1, i) = Cells(lr, i + 2)
  Next
  '
  'Sort columns
  For Each a In Range("C4", Range("C" & Rows.Count).End(3)).SpecialCells(xlCellTypeConstants).Areas
    b = a.Resize(a.Rows.Count, cols).Value
    ReDim c(1 To UBound(b, 1), 1 To UBound(b, 2))
    For j = 1 To UBound(b, 2)
      c(1, j) = e(1, j)
      If b(1, j) <> "" Then
        n = Replace(Split(b(1, j), "(")(1), ")", "")
        For i = 1 To UBound(b, 1)
          c(i, n) = b(i, j)
        Next i
      End If
    Next j
    a.Resize(a.Rows.Count, 7).Value = c
  Next a
  End Sub

[Paul_Hossler]

try this and see

Option Explicit


Sub Reformat()
    Dim ws As Worksheet
    Dim rData As Range, rCompany As Range
    Dim iCol As Long, iRow As Long
    
    Set ws = Worksheets("Before")
    
    Set rData = Intersect(ws.UsedRange, ws.Columns(1).Resize(, 5))
    
    For iRow = 1 To rData.Rows.Count
        With rData
            
            If .Cells(iRow, 1).Value <> "Company" Then GoTo NextRow
            
            Set rCompany = .Cells(iRow, 1).CurrentRegion
            
            For iCol = 2 To 5
                Select Case iCol
                    Case 2
                        If .Cells(iRow, iCol).Value <> "Inno-Tech (a)" Then
                            rCompany.Columns(iCol).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                            .Cells(iRow, iCol).Value = "Inno-Tech (a)"
                        End If
                    Case 3
                        If .Cells(iRow, iCol).Value <> "TechSoft (b)" Then
                            rCompany.Columns(iCol).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                            .Cells(iRow, iCol).Value = "TechSoft (b)"
                        End If
                    Case 4
                        If .Cells(iRow, iCol).Value <> "MaKS.IT (c)" Then
                            rCompany.Columns(iCol).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                            .Cells(iRow, iCol).Value = "MaKS.IT (c)"
                        End If
                    Case 5
                        If .Cells(iRow, iCol).Value <> "MYMAN-Group (d)" Then
                            rCompany.Columns(iCol).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                            .Cells(iRow, iCol).Value = "MYMAN-Group (d)"
                        End If
                End Select
            Next iCol
        End With
NextRow:
    Next iRow


    MsgBox "Done"


End Sub

[p45cal]

In the attached are several offerings:

1. Your macro with minimal changes to make it work as I think was intended.
It seems that headers such as Inno-Tech (a) and MYMAN-Group (d) were originally intended to have numbers instead of letters, so that they become Inno-Tech (1) and MYMAN-Group (4) with the numbers deciding on the order (left to right) of the headers. [This is because the macro Dims n as a Long and the line: n = Replace(Split(b(1, j), "(")(1), ")", "") is designed to fetch the character between parentheses into n]
So I copied your Before sheet to Before (macro) and changed all those headers, then ran the updated Company_names_in_Table_Sort_Interpretive macro. Currently the penultimate line of that macro puts the results offset to the right to preserve the original data, but you can overwrite the existing data (see alternative line currently commented-out).
I've indicated the minor changes I've made to the macro as comments.
The macro works on the active sheet.

2. A Power Query solution, similar results to the macro but with a nod to your

Since I want to further process the sheets, I need a uniform structure of the data.

The result is on the sheet PQ Results which is based on the data in the Before (PQ) sheet (which is a copy of your Before sheet but I've assumed that where you have Company in cells A4, A38 etc. that these are really real company names that you've 'sanitised' for this forum, so I've put some fictitious company names in there; I hope I'm right).
Power Query queries need refreshing (like a pivot table) when the base data changes, so I've written a very short macro called UpdateNamedRange which finds the range on the active sheet to work on (in the same way as your macro does) and gives it a name (RangeToProcess), and it's this named range that the query uses as its source data. The macro then goes on to refresh the query. Well, queries, because…

3. …another Power Query query (actually it uses the first query and adds one more step) on sheet FlatFile which is the same data in a format ideal for the likes of further processing, such as the creation of pivot tables like the one found on the sheet called Pivot, which I've just arranged to be similar to the source data. You might need to refresh this pivot yourself.

The Power Query offerings do lose some data from your Before sheet: The lines containing Comparative Results - Industry Detail and Performance Measures for Period 1, ind1:. Don't remove the lines beginning Comparative Results - because the queries use that to split out the different companies.
They should cope with different headers and amounts of headers.

It could be more robust and easier (in the long run) if the data that's in the Before sheet has itself come from elsewhere, perhaps external files, other Excel workbooks, database files, web, whatever, because Power Query would likely be able to gain access to the data in these files more reliably and quicker than getting it from a sheet.

[Sinlink]

Thank you p45cal. That solution looks awesome. But it is above my head.
But thank you very much I am so motivated to look deeper into Power Query.

[Sinlink]

Thank you Paul_Hossler.
Your solution hapls 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.

[p45cal]

Run this:

Sub ReplaceStuff()
FromArray = Array("(a)", "(b)", "(c)", "(d)", "(e)", "(f)", "(g)")
ToArray = Array("(1)", "(2)", "(3)", "(4)", "(5)", "(6)", "(7)")
For i = LBound(FromArray) To UBound(FromArray)
  Cells.Replace What:=FromArray(i), Replacement:=ToArray(i), LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Next i
End Sub

before running your original macro and you're nearly there.

[Sinlink]

Thanks you that helped.
Thanks to anyone who helped.
THAT WAS AWESOME!

Can I give a positive Rating in this forum to the helpers?

[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