CODEWITHSUNDEEP
excelvba
Shelby Pons
Shelby Pons

Reputation: 13

Table/Array Manipulation to consolidate multi-column selection

I'm trying to convert a table to reflect baskets per fruit item instead of fruit per basket number. Kind of like a transpose action, but the data changes.

Original data shows Basket No. with identifier per fruit basket. Next to each fruit basket number, there are 10 columns with "Fruit 1," "Fruit 2," etc with list validation.
original data

Instead of showing "[Basket No.]/[fruit1]/[fruit2]/etc," I need to see the fruit names as table headers, with each basket those fruits are included in under their name.
intended output

I'm thinking there is a way to add more rows to create one big fruit column with duplicate basket numbers, then consolidate from that point. I do not know where to get started with this, despite searching.

Upvotes: 0

Views: 112

Answers (2)

Noah Bridge
Noah Bridge

Reputation: 345

Assuming that you do not want to use Power Query, there is a "brute-force" way to do this using VBA. You could, for example, place the following code in a new VBA module:

Option Compare Text 'To keep string comparisons case-insensitive
Option Explicit

Sub InvertLists(ByVal dataRange As Range, ByRef outputCell As Range)
  '[dataRange] should have horizontal lists of "fruits" in each "basket"
  'This method will produce vertical lists of "baskets" for each "fruit"
  'WARNING: If [dataRange] is of size R x C, this method will overwrite all
  '  the data in a (R + 1) x (C - 1) rectangle starting in [outputCell]
  'ASSUMPTION: [dataRange] does not include any header row, just the "fruit" lists

  'Read in the current table of data
  Dim oldArr As Variant: oldArr = dataRange.value

  'A single cell cannot be inverted
  If Not IsArray(oldArr) Then 'There is only 1 cell in the range
    outputCell.value = "#ERROR: No data to invert"
    Exit Sub
  End If

  'Get the old table's dimensions
  Dim rowLb As Long: rowLb = LBound(oldArr, 1)
  Dim rowUb As Long: rowUb = UBound(oldArr, 1)
  Dim colLb As Long: colLb = LBound(oldArr, 2)
  Dim colUb As Long: colUb = UBound(oldArr, 2)
  Dim oldRowCnt As Long: oldRowCnt = rowUb - rowLb + 1
  Dim oldColCnt As Long: oldColCnt = colUb - colLb + 1

  'There is no way to do the inversion if the input range only has 1 column
  If colUb <= colLb Then
    outputCell.value = "#ERROR: Range must have 2+ columns"
    Exit Sub
  End If

  'The new table will have 1 extra row and 1 less column
  Dim newArr() As Variant
  ReDim newArr(1 To oldRowCnt + 1, 1 To oldColCnt - 1)

  Dim newColCnt As Long: newColCnt = 0 'To count the number of new columns

  Dim rowValue As Variant, gridValue As Variant
  Dim found As Boolean
  Dim r As Long, c As Long, nr As Long, nc As Long
  'Go row by row in the old table
  For r = rowLb To rowUb
    rowValue = oldArr(r, colLb) '"Basket" at the start of the row

    'Go through the rest of the row in the old table;
    '  the rest of the row is a HORIZONTAL list of "fruits"
    For c = colLb + 1 To colUb
      gridValue = oldArr(r, c) '"Fruit" to place somewhere in row 1 of the new table
      'A blank value means the end of the list in the current row
      If gridValue & "" = "" Then GoTo row_Continue

      'Look for [gridValue] amongst the "fruits" in the new row 1
      found = False
      nc = 0
      Do While Not found And nc < newColCnt
        nc = nc + 1
        found = (newArr(1, nc) & "" = gridValue & "")
      Loop
      If Not found Then
        newColCnt = newColCnt + 1 'We have a new "fruit" in the new table
        nc = newColCnt
        newArr(1, nc) = gridValue 'Add the new "fruit" in row 1
      End If
      'If we are here, we know newArr(1, nc) equals gridValue

      'Look for [rowValue] in the list of "baskets" in column [nc] of new data;
      '  the new table will have VERTICAL lists of "baskets"
      found = False
      nr = 1 'Each list of "baskets" starts in row 2 (row 1 has [gridValue], the "fruit" name)
      Do Until found Or nr > oldRowCnt
        nr = nr + 1
        If newArr(nr, nc) & "" = "" Then Exit Do 'Blank value = end of vertical list

        found = (newArr(nr, nc) & "" = rowValue & "")
      Loop
      'Add [rowValue] to the list of "baskets" in column [nc] if it was not there already
      If Not found Then newArr(nr, nc) = rowValue
    Next 'c
row_Continue:
  Next 'r

  'Write out the new table, starting at [outputCell]
  outputCell.Resize(oldRowCnt + 1, oldColCnt - 1).value = newArr
End Sub

To use this method for a specific range of cells, you would need to add a macro such as the one below (in a separate module, or along with the previous code) ...

Sub DoSpecificInversion()
  InvertLists Range("A2:K9"), Range("A13")
End Sub

Naturally, you would have to change the range "A2:K9" to where you have your original table (excluding the headers row), and you would have to change "A13" to the cell where the new table would be copied. You could then add a button and attach it to that macro. After clicking on the button, you would have something like the following:

Sample macro results

If the original table, without the headers, is R rows by C columns in size, the new table will be (R + 1) rows by (C - 1) columns in size. Since the macro overwrites data in the workbook, you may want to save a copy of the workbook before running the macro for the first time.

Upvotes: 1

Noah Bridge
Noah Bridge

Reputation: 345

As Ron Rosenfeld shared in his comment to the question, this operation seems doable with Power Query. Since you basically start with a crosstab table, you can probably do the following in Power Query:

  1. Unpivot the crosstab table (using the steps in this excelchamps.com page)
  2. Drop the "Attribute" column (with the "Fruit 1", "Fruit 2", "Fruit 3", etc. values)
  3. Rename the "Value" column (with the fruit names) to "Fruit"
  4. Delete any rows where the "Fruit" column is blank
  5. Add a "BasketIndex" column that numbers the rows for each fruit (using the steps in this excelguru.ca page); this will involve grouping by the "Fruit" column
  6. Pivot the new table, using the new "BasketIndex" column for rows, the "Fruit" column for columns, and the "Basket" column for values (without aggregating it)
  7. Write the table out to the desired cells, excluding the "BasketNumber" column

Forgive my ignorance if there is an easier way to do this in Power Query, but these would be the steps I would follow.

Upvotes: 0

Related Questions