Reverse columns and Rows

[chocho]

I have a list of variable x and for each entry in x there are multiple entries in list y. Need to reverse so that for each y there are multiple xs.
See example Example.xlsx for mini problem and solution. Looking for a way to accomplish this. Thanks in advance!

[GTO]

Greetings chocho,

In a Standard Module:

Option Explicit
  
Sub example()
Dim DIC         As Object ' Scripting.Dictionary
Dim rngLastRow  As Range
Dim rngLastCol  As Range
Dim rngDataIn   As Range
Dim rngDataRow  As Range
Dim Cell        As Range
Dim Cell2       As Range
Dim wks         As Worksheet
Dim Output      As Variant
Dim Items       As Variant
Dim Keys        As Variant
Dim arrTmp      As Variant
Dim n           As Long
Dim x           As Long
  
  With Sheet1 '<---Using the sheet's CodeName,
              ' or using the name on the tab ---> ThisWorkbook.Worksheets("Problem")
    
    '// Find last row w/data  //
    Set rngLastRow = RangeFound(.Cells)
    
    '// Bailout point   //
    If rngLastRow Is Nothing Then Exit Sub
    
    Set DIC = CreateObject("Scripting.Dictionary")
    
    '// Set a reference to range w/data in Col A  //
    Set rngDataIn = .Range(.Range("A1"), .Cells(rngLastRow.Row, 1))
    
    '// Looping thru these cells, ... //
    For Each Cell In rngDataIn.Cells
      
      '// Ensure there are values in Col B thru x, and if so... //
      Set rngLastCol = Nothing
      Set rngLastCol = RangeFound(Cell.Offset(, 1).Resize(, .Columns.Count - 1), SearchRowCol:=xlByColumns)
      If rngLastCol Is Nothing Then GoTo 9
      If rngLastCol.Column < 2 Then GoTo 9
      Set rngDataRow = Range(Cell.Offset(, 1), rngLastCol)
      
      '// loop thru those cells.    //
      For Each Cell2 In rngDataRow.Cells
        
        '// If a key doesn't yet exist, create it and plunk in a one-element //
        '// array to hold the value from Col A.                              //
        If Not DIC.Exists(Cell2.Value) Then
          ReDim arrTmp(0 To 0)
          arrTmp(0) = Cell2.Offset(, (Cell2.Column - 1) * -1).Value
          DIC.Add Cell2.Value, arrTmp
        Else
          '// Else, extract the current array assigned to the Key's Item, ...   //
          arrTmp = DIC.Item(Cell2.Value)
          '// Resize the array and put the value in its topmost element.        //
          ReDim Preserve arrTmp(0 To UBound(arrTmp, 1) + 1)
          arrTmp(UBound(arrTmp, 1)) = Cell2.Offset(, (Cell2.Column - 1) * -1).Value
          '// Then put the array back into the dictionary.                      //
          DIC.Item(Cell2.Value) = arrTmp
        End If
      Next
9:   Next
  End With
  
  '// Flip the items/keys into arrays (for late-binding)  //
  Items = DIC.Items
  Keys = DIC.Keys
  
  '// See what the maximum number of columns needed will be.  //
  For n = 0 To UBound(Items)
    x = Application.Max(x, (UBound(Items(n)) - LBound(Items(n)) + 1))
  Next
  
  '// Size an output array  //
  ReDim Output(1 To (UBound(Keys) - LBound(Keys) + 1), 1 To x + 1)
  
  '// Then loop thru thru the keys and items, placing the values into //
  '// the proper elements of the output array.                        //
  For n = 1 To UBound(Keys) + 1
    Output(n, 1) = Keys(n - 1)
    For x = 1 To UBound(Items(n - 1)) - LBound(Items(n - 1)) + 1
      Output(n, x + 1) = Items(n - 1)(x - 1)
    Next
  Next
  
  '// Plunk the results where you want. //
  Set wks = ThisWorkbook.Worksheets.Add(, , , xlWorksheet)
  wks.Range("A1").Resize(UBound(Output), UBound(Output, 2)).Value = Output
  
End Sub
  
Function RangeFound(SearchRange As Range, _
                    Optional ByVal FindWhat As String = "*", _
                    Optional StartingAfter As Range, _
                    Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
                    Optional LookAtWholeOrPart As XlLookAt = xlPart, _
                    Optional SearchRowCol As XlSearchOrder = xlByRows, _
                    Optional SearchUpDn As XlSearchDirection = xlPrevious, _
                    Optional bMatchCase As Boolean = False) As Range
    
    If StartingAfter Is Nothing Then
        Set StartingAfter = SearchRange(1)
    End If
    
    Set RangeFound = SearchRange.Find(What:=FindWhat, _
                                      After:=StartingAfter, _
                                      LookIn:=LookAtTextOrFormula, _
                                      LookAt:=LookAtWholeOrPart, _
                                      SearchOrder:=SearchRowCol, _
                                      SearchDirection:=SearchUpDn, _
                                      MatchCase:=bMatchCase)
End Function

Hope that helps,

Mark

[chocho]

You are awesome. Thanks so much.

[GTO]

You are most welcome :-)

[snb]

or:

Sub M_snb()
    sn = Sheets("problem").Cells(1).CurrentRegion
    
    With CreateObject("scripting.dictionary")
        For j = 1 To UBound(sn)
           For jj = 2 To UBound(sn, 2)
             If sn(j, jj) <> "" Then .Item(sn(j, jj)) = IIf(.Item(sn(j, jj)) = "", sn(j, jj) & "_", .Item(sn(j, jj)) & "_") & sn(j, 1)
           Next
        Next
        
        Sheets("solution").Cells(1, 6).Resize(.Count) = Application.Transpose(.items)
        Sheets("solution").Columns(6).TextToColumns , , , , 0, 0, 0, 0, -1, "_"
    End With
End Sub

[chocho]

Already done but thanks for another solution!