Multi-dimensional table into single table in excel

[Basket]

Hi Team , I have a multi dimensional table, I want to convert that table into single -D table

This is the type of excel I’ll be working on
In this select the column right next to the orange cell

In which ever cell , if there is “X” value Select the corresponding row. Suppose If I select the column F since its the column right next to Orange color cell,
I'll go for Row 6 and I'll select, Location 1,dsf,Neutral and fruit and paste it in a separate worksheets. Similarly next I'll go for column 6.

Then I'll search for next Orange cell and column right next to it and continue this operation. how should I proceed.

[snb]

You'd better use a table ( menu/Insert/table).

[Basket]

Hello snb, this is just one small part of the table , is there any way we could automate this by using for the entire table using VBA

[JeffreyWeir]

Basket - can you amend your sample file so that it also shows how the data looks in the table that you're pasting it to?

[Basket]

Hi Jeffrey Please find the above screenshots.

[JeffreyWeir]

So you don't record at all what shop was involved? e.g from the input sheet we can see that the data from that first line came from shop 1 at Walmart. But your output table doesn't record this information. Is there a reason for this?

[p45cal]

try this on the active sheet:

Sub blah()
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(2, Columns.Count).End(xlToLeft).Column
DestnRow = lr + 5
For Each cll In Range(Range("E3"), Cells(lr, lc)).SpecialCells(xlCellTypeConstants, 2).Cells
  If cll.Value = "X" Then
    Set RoleCell = Cells(1, cll.Column)
    Cells(DestnRow, 1).Resize(, 6).Value = Array(IIf(Len(RoleCell.Value) > 0, RoleCell.Value, RoleCell.End(xlToLeft).Value), Cells(cll.Row, 1).Value, Cells(cll.Row, 2).Value, Cells(cll.Row, 3).Value, Cells(cll.Row, 4).Value, Cells(2, cll.Column).Value)
    DestnRow = DestnRow + 1
  End If
Next cll
End Sub

[p45cal]

Suppose If I select the column F since its the column right next to Orange color cell
<snip>
Then I'll search for next Orange cell and column right next to it and continue this operation. how should I proceed.

Have I got it right that the red and orange columns are organisations and columns to the right are shops belonging to that organisation? And that you'll never expect 'X' in those columns?

If so, 2 tweaks to my last offering; one to change the order of the results to make it similar to your screen shot, the other to add a column showing the organisation. If you don't like the last two columns, delete them.

Sub blah4()
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(2, Columns.Count).End(xlToLeft).Column
DestnRow = lr + 5
For Each colm In Range(Range("E3"), Cells(lr, lc)).Columns
  For Each cll In colm.SpecialCells(xlCellTypeConstants, 2).Cells
    If cll.Value = "X" Then
      Set RoleCell = Cells(1, cll.Column)
      If Len(RoleCell.Value) = 0 Then Set RoleCell = RoleCell.End(xlToLeft)
      Cells(DestnRow, 1).Resize(, 7).Value = Array(RoleCell.Value, Cells(cll.Row, 1).Value, Cells(cll.Row, 2).Value, Cells(cll.Row, 3).Value, Cells(cll.Row, 4).Value, RoleCell.Offset(1).Value, Cells(2, cll.Column).Value)
      DestnRow = DestnRow + 1
    End If
  Next cll
Next colm
End Sub

(I haven't bothered not searching columns E and H so I hope there are no 'X's in there.)
(The results are 5 rows below the table.)

[snb]

Sub M_snb()
   On Error Resume Next
   
   With Sheet1.Cells(1).CurrentRegion
      For j = 5 To .Columns.Count
        .AutoFilter j, "X"
        If .Columns(1).SpecialCells(12).Count > 1 Then
            x2 = Sheets(LCase(Sheet1.Cells(2, j).Value)).Cells(1).Value
            If Err.Number <> 0 Then Sheets.Add(, Sheets(Sheets.Count)).Name = LCase(Sheet1.Cells(2, j).Value)
            Err.Clear
            .Offset(1).Copy Sheets(Sheet1.Cells(2, j).Value).Cells(Rows.Count, 1).End(xlUp).Offset(1)
        End If
        .AutoFilter
      Next
    End With
End Sub