tricky transpond data

chilly_bang

Board Regular
Joined
Jun 17, 2016
Messages
57
Hi
I have a table, looking like:

ABCDE
1xloremipsumdolor
2yunodostresquattro
3zfoobar

<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:
AB
1xlorem
2xipsum
3xdolor
4yuno
5ydos
6ytres
7yquattro
8zfoo
9zbar

<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.
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

tygrrboi

Well-known Member
Joined
Sep 8, 2015
Messages
1,196
Something like this?


Code:
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
 
Last edited:
Upvote 0

Tetra201

MrExcel MVP
Joined
Oct 14, 2016
Messages
3,832
Another approach. Creates a new sheet with re-arranged data. Much faster.
Code:
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
 
Upvote 0

hiker95

Well-known Member
Joined
Apr 8, 2009
Messages
17,649
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
ABCDEF
1xloremipsumdolor
2yunodostresquattro
3zfoobar
4
5
6
7
8
9
10
Sheet1


And, after the macro in the active worksheet:


Excel 2007
ABCDEF
1xlorem
2xipsum
3xdolor
4yuno
5ydos
6ytres
7yquattro
8zfoo
9zbar
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).

Code:
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.
 
Upvote 0

chilly_bang

Board Regular
Joined
Jun 17, 2016
Messages
57
ADVERTISEMENT
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
Code:
=countif($a$2:a2;a2)
Is it a big deal to add this counting step into VBA script?
 
Last edited:
Upvote 0

hiker95

Well-known Member
Joined
Apr 8, 2009
Messages
17,649
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.
 
Last edited:
Upvote 0

hiker95

Well-known Member
Joined
Apr 8, 2009
Messages
17,649
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
ABCDEF
1xloremipsumdolor
2yunodostresquattro
3zfoobar
4
5
6
7
8
9
10
Sheet1


And, after the new macro:


Excel 2007
ABCDEF
1xlorem1
2xipsum2
3xdolor3
4yuno1
5ydos2
6ytres3
7yquattro4
8zfoo1
9zbar2
10
Sheet1
Cell Formulas
RangeFormula
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).

Code:
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.
 
Last edited:
Upvote 0

Tetra201

MrExcel MVP
Joined
Oct 14, 2016
Messages
3,832
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.
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
 
Last edited:
Upvote 0

Forum statistics

Threads
1,195,700
Messages
6,011,196
Members
441,594
Latest member
AVO

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top