PDA

View Full Version : [SOLVED] Reverse columns and Rows



chocho
02-02-2014, 04:18 PM
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 11213 for mini problem and solution. Looking for a way to accomplish this. Thanks in advance!

GTO
02-02-2014, 06:53 PM
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
02-02-2014, 07:25 PM
You are awesome. Thanks so much.

GTO
02-02-2014, 11:48 PM
You are most welcome :-)

snb
02-03-2014, 06:32 AM
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
02-04-2014, 08:06 AM
Already done but thanks for another solution!