Paste: trouble with transposing

[beauriddly]

Hi,

I need to go from format "a)" to "b)".
This is more complicated than a regular transpose, as you will see:

a)
[TABLE="width: 500"]
<tbody>[TR]
[TD]a1
[/TD]
[TD]b1
[/TD]
[/TR]
[TR]
[TD]a2
[/TD]
[TD]b2
[/TD]
[/TR]
[TR]
[TD]a3
[/TD]
[TD]b3
[/TD]
[/TR]
[TR]
[TD]a4
[/TD]
[TD]b4
[/TD]
[/TR]
</tbody>[/TABLE]

b)
[TABLE="width: 500"]
<tbody>[TR]
[TD]a1
[/TD]
[TD]b1
[/TD]
[TD]a2
[/TD]
[TD]b2
[/TD]
[TD]a3
[/TD]
[TD]b3
[/TD]
[TD]a4
[/TD]
[TD]b4
[/TD]
[/TR]
</tbody>[/TABLE]

Thank you in advance!!

T

 

[hiker95]

beauriddly,

Welcome to the MrExcel forum.


With the only raw data in your worksheet in range A1:B4, the macro will re-arrange your data per your example to range A1:H1.


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

1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Option Base 1
Sub ReorgData()
' hiker95, 01/13/2013
' http://www.mrexcel.com/forum/excel-questions/679053-paste-trouble-transposing.html
Dim i As Variant, o As Variant
Dim r As Long, c As Long, rr As Long
i = Range("A1").CurrentRegion
ReDim o(1 To UBound(i, 1) * UBound(i, 2), 1 To 1)
rr = 0
For r = 1 To UBound(i, 1)
  For c = 1 To UBound(i, 2)
    If i(r, c) <> "" Then
      rr = rr + 1
      o(rr, 1) = i(r, c)
    End If
  Next c
Next r
Range("A1").CurrentRegion.ClearContents
Range("A1").Resize(, UBound(o)).Value = Application.Transpose(o)
Erase i
Erase o
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


Then run the ReorgData macro.

 

[Tom Urtis]

Assuming your data table exists in range A1:B4, and you want your results horizontally in range A6:H6, enter this formula into cell A6 and copy to H6.

=INDIRECT(ADDRESS(INT((COLUMN()+1)/2),MOD(COLUMN()+1,2)+1))



Just an aside, if you should want to list that original range vertically instead of horizontally, you can enter the following formula into cell A6 and copy it down to cell A13.

=INDEX($A$1:$B$4,MOD(ROWS($1:4),4)+1,ROWS($1:4)/4)

 

[mirabeau]

Sub just_for_interest()
Dim r As Range
For Each r In Cells(1).CurrentRegion.Rows
    If r.Row > 1 Then r.Cut Cells(, Columns.Count).End(1).Offset(, 1)
Next
End Sub

 

[hiker95]

Team,

mirabeau's code ran in 0.016 seconds

hiker95's code ran in 0.00 seconds

 

[beauriddly]

Thanks for all the detailed answers! Tried them all and they all worked great.

 

[hiker95]

beauriddly,

You are very welcome. Glad we could help.

Thanks for the feedback.

Come back anytime.

 

[Rick Rothstein]

Option Explicit
Option Base 1
Sub ReorgData()
' hiker95, 01/13/2013
' http://www.mrexcel.com/forum/excel-questions/679053-paste-trouble-transposing.html
Dim i As Variant, o As Variant
Dim r As Long, c As Long, rr As Long
i = Range("A1").CurrentRegion
ReDim o(1 To UBound(i, 1) * UBound(i, 2), 1 To 1)
rr = 0
For r = 1 To UBound(i, 1)
  For c = 1 To UBound(i, 2)
    If i(r, c) <> "" Then
      rr = rr + 1
      o(rr, 1) = i(r, c)
    End If
  Next c
Next r
Range("A1").CurrentRegion.ClearContents
Range("A1").Resize(, UBound(o)).Value = Application.Transpose(o)
Erase i
Erase o
End Sub

An alternative that uses a single loop and avoids using Application.Transpose...

Sub ReorgData2()
  Dim R As Long, ArrIn As Variant, ArrOut As Variant
  ArrIn = Range("A1").CurrentRegion
  ReDim ArrOut(1 To 1, 1 To 2 * UBound(ArrIn))
  For R = 1 To UBound(ArrIn)
    ArrOut(1, 2 * R - 1) = ArrIn(R, 1)
    ArrOut(1, 2 * R) = ArrIn(R, 2)
  Next
  Range("A1").CurrentRegion.ClearContents
  Range("A1").Resize(, 2 * UBound(ArrIn)) = ArrOut
End Sub

 

[hiker95]

Rick,

Thanks again - something for my archives.

Both our macros ran in 0.000 seconds.

 

[Tom Urtis]

I'd still recommend the native formula route, faster than VBA and easier to implement.