tricky transpond data

[chilly_bang]

Hi
I have a table, looking like:

	A	B	C	D	E
1	x	lorem	ipsum	dolor
2	y	uno	dos	tres	quattro
3	z	foo	bar

<tbody>
</tbody>

Such tables can have different amount of rows or columns, but they have always the same structure: column A has always IDs, all values in columns B, C, ... belong always to the ID in the column A of their row. So, x in A1 is an ID, lorem, ipsum, dolor in B1, C1, D1 are values of x in A1.


Now i want re-organize the table, so it'll look like:

	A	B
1	x	lorem
2	x	ipsum
3	x	dolor
4	y	uno
5	y	dos
6	y	tres
7	y	quattro
8	z	foo
9	z	bar

<tbody>
</tbody>

So, all values of all IDs should stay in the one, same column, one below other, and beside of every value (on the left or on the right - not important) should stay the ID the value belongs to.


Any help is highly welcome! - thanks and best regards.

 

[tygrrboi]

Something like this?

Sub PutTogether()
Dim V As Variant
Dim x As Long, y As Long, c As Long


V = Range("A1:Z100")[COLOR=#008000] 'your whole range you want the data to come from
[/COLOR][COLOR=#ff0000]'[/COLOR][COLOR=#008000]Range("A1:Z100").ClearContents    ' remove [/COLOR][COLOR=#ff0000]the apostrophe[/COLOR][COLOR=#008000] in the beginning of this line if you want to clear the original data... It's gone forever and cannot CTRL Z to undo... [/COLOR]
c = 1
For x = LBound(V, 1) To UBound(V, 1)
    For y = LBound(V, 2) + 1 To UBound(V, 2)
        If V(x, y) = vbNullString Then
            Exit For
        Else
            Range("G" & c) = V(x, LBound(V, 2)) [COLOR=#008000]'Change the letter of the range in here to the column you want your IDs in.[/COLOR]
            Range("H" & c) = V(x, y)[COLOR=#008000] 'Change the letter of the range in here to the column you want your words listed in. 
[/COLOR][COLOR=#008000]            '(note):  If you want to put them into columns A and B like you showed in your example... you will have to first clear the original data using the code I commented out above
            'If you want it on a different sheet, you can specify that using[/COLOR] [COLOR=#ffa500]Sheets("sheetname").Range( [/COLOR][COLOR=#008000]  to replace the start of the code above.  [/COLOR]
        End If
        c = c + 1
    Next y
Next x


End Sub

 

[Tetra201]

Another approach. Creates a new sheet with re-arranged data. Much faster.

Sub Tricky_Transp()
    Application.ScreenUpdating = False
    Set WS1 = ActiveSheet: WS1.Copy After:=WS1
    Set WS2 = ActiveSheet: Cells.ClearContents
    WS1.Select: StartRow = 1
    For Each cll In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
        LastCol = Cells(cll.Row, Columns.Count).End(xlToLeft).Column
        LastRow = WorksheetFunction.Max(1, StartRow + LastCol - 2)
        WS2.Range("B" & StartRow & ":B" & LastRow) = WorksheetFunction.Transpose _
            (Range(Cells(cll.Row, 2), Cells(cll.Row, LastCol)))
        WS2.Range("A" & StartRow) = Cells(cll.Row, 1)
        If LastRow > StartRow Then WS2.Range("A" & StartRow).AutoFill _
            Destination:=WS2.Range("A" & StartRow & ":A" & LastRow)
        StartRow = LastRow + 1
    Next cll
    WS2.Select
    Application.ScreenUpdating = True
End Sub

 

[hiker95]

chilly_bang,

Here is another macro solution for you to consider that uses two arrays in memory (should be very fast), and, will adjust to the number of raw data rows, and, columns.

Sample raw data in the active worksheet:

Excel 2007
	A	B	C	D	E	F
1	x	lorem	ipsum	dolor
2	y	uno	dos	tres	quattro
3	z	foo	bar
4
5
6
7
8
9
10
Sheet1

And, after the macro in the active worksheet:

Excel 2007
	A	B	C	D	E	F
1	x	lorem
2	x	ipsum
3	x	dolor
4	y	uno
5	y	dos
6	y	tres
7	y	quattro
8	z	foo
9	z	bar
10
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub ReorgData()
' hiker95, 12/09/2016, ME979930
Dim a As Variant, i As Long, c As Long
Dim o As Variant, j As Long
Dim lr As Long, lc As Long, n As Long
Application.ScreenUpdating = False
With ActiveSheet
  lr = .Range("A1").CurrentRegion.Rows.Count
  lc = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  n = Application.CountA(.Range(.Cells(1, 2), .Cells(lr, lc)))
  ReDim o(1 To n, 1 To 2)
  For i = LBound(a, 1) To UBound(a, 1)
    For c = 2 To UBound(a, 2)
      If Not a(i, c) = vbEmpty Then
        j = j + 1: o(j, 1) = a(i, 1): o(j, 2) = a(i, c)
      End If
    Next c
  Next i
  .Range(.Cells(1, 1), .Cells(lr, lc)).ClearContents
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).Resize(, UBound(o, 2)).AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ReorgData macro.

 

[chilly_bang]

Absolutely amazing: everything works like a charm - tested on some thousands of rows.

Just a short follow up question:
after results are reorganized with your VBA scripts, i count them in an additional column to give values, which belong to the same ID, forthcoming numbers. To do so i use the formula

=countif($a$2:a2;a2)

Is it a big deal to add this counting step into VBA script?

 

[hiker95]

Absolutely amazing: everything works like a charm - tested on some thousands of rows.

chilly_bang,

Thanks for the feedback.

You are very welcome. Glad we could help.

Is it a big deal to add this counting step into VBA script?

Be right back.

 

[hiker95]

chilly_bang,

If I understand your latest request correctly, then here is another macro solution for you to consider that uses two arrays in memory (should be very fast), and, will adjust to the number of raw data rows, and, columns.

Sample raw data in the active worksheet:

Excel 2007
	A	B	C	D	E	F
1	x	lorem	ipsum	dolor
2	y	uno	dos	tres	quattro
3	z	foo	bar
4
5
6
7
8
9
10
Sheet1

And, after the new macro:

Excel 2007
	A	B	C	D	E	F
1	x	lorem	1
2	x	ipsum	2
3	x	dolor	3
4	y	uno	1
5	y	dos	2
6	y	tres	3
7	y	quattro	4
8	z	foo	1
9	z	bar	2
10
Sheet1

Cell Formulas
Range	Formula
C1	=COUNTIF($A$1:A1,A1)

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub ReorgData_V2()
' hiker95, 12/10/2016, ME979930
Dim a As Variant, i As Long, c As Long
Dim o As Variant, j As Long
Dim lr As Long, lc As Long, n As Long
Application.ScreenUpdating = False
With ActiveSheet
  lr = .Range("A1").CurrentRegion.Rows.Count
  lc = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  n = Application.CountA(.Range(.Cells(1, 2), .Cells(lr, lc)))
  ReDim o(1 To n, 1 To 2)
  For i = LBound(a, 1) To UBound(a, 1)
    For c = 2 To UBound(a, 2)
      If Not a(i, c) = vbEmpty Then
        j = j + 1: o(j, 1) = a(i, 1): o(j, 2) = a(i, c)
      End If
    Next c
  Next i
  .Range(.Cells(1, 1), .Cells(lr, lc)).ClearContents
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  With .Range("C1:C" & UBound(o, 1))
    .Formula = "=COUNTIF($A$1:A1,A1)"
  End With
  .Columns(1).Resize(, UBound(o, 2)).AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ReorgData_V2 macro.

 

[Tetra201]

Is it a big deal to add this counting step into VBA script?

Here is my modified code. If you need count numbers, not formulas, un-comment the three lines by the bottom of the code.

Sub Tricky_Transp2()
    Application.ScreenUpdating = False
    Set WS1 = ActiveSheet: WS1.Copy After:=WS1
    Set WS2 = ActiveSheet: Cells.ClearContents
    WS1.Select: StartRow = 1
    For Each cll In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
        LastCol = Cells(cll.Row, Columns.Count).End(xlToLeft).Column
        LastRow = WorksheetFunction.Max(1, StartRow + LastCol - 2)
        WS2.Range("B" & StartRow & ":B" & LastRow) = WorksheetFunction.Transpose _
            (Range(Cells(cll.Row, 2), Cells(cll.Row, LastCol)))
        WS2.Range("A" & StartRow) = Cells(cll.Row, 1)
        If LastRow > StartRow Then WS2.Range("A" & StartRow).AutoFill _
            Destination:=WS2.Range("A" & StartRow & ":A" & LastRow)
        StartRow = LastRow + 1
    Next cll
    WS2.Select
    Range("C1:C" & LastRow).FormulaR1C1 = "=COUNTIF(R1C1:RC[-2],RC[-2])"
'    Columns("C:C").Copy
'    Columns("C:C").PasteSpecial Paste:=xlPasteValues
'    Application.CutCopyMode = False
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub