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