# Transposing Numbers

#### howard

##### Well-known Member
I have and would like to transpose all if these one below the other. Have shown example of what it must look like after transposing the data

I have a huge amount of data to transpose

Excel 2012
ABCDE
13300433005330073300833009
23300333006
33324433245332473324833249
43324333246
53302433025330273302833029
6
733004
833005
933007
1033008
1133009
1233006
1333245
1433247
1533248
1633249
1733246
1833025
1933027
2033028
2133029
Sheet1

### Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Signing out, but just a quick question if it helps others help you...

Why are the values in A2:A5 (33003, 33244, 33243, 33024) missing in the output range, when the value in A1 is included?

Mark

Thanks for pointing this out Mark

See raw data A1:E5 as well as I would like the output to look like

Excel 2012
ABCDEF
13300433005330073300833009
23300333006
33324433245332473324833249
43324333246
53302433025330273302833029
6
7
8
9
10
11OutPut
12
1333004
1433005
1533007
1633008
1733009
1833003
1933006
2033244
2133245
2233247
2333248
2433249
2533243
2633246
2733024
2833025
2933027
3033028
3133029
Sheet1

Give this macro a try (it should be quite fast, even with your huge amount of data). Note that I send the output to Sheet2 starting in cell A1 (see blue text below).

Code:
``````Sub TransposeData()
Dim R As Long, C As Long, X As Long, LastRow As Long, LastCol As Long, Data As Variant, DataOut As Variant
LastRow = Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
LastCol = Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
Data = Range("A1", Cells(LastRow, LastCol))
ReDim DataOut(1 To Application.CountA(Range("A1", Cells(LastRow, LastCol))), 1 To 1)
For R = 1 To UBound(Data)
For C = 1 To UBound(Data, 2)
If Len(Cells(R, C).Value) Then
X = X + 1
DataOut(X, 1) = Cells(R, C).Value
End If
Next
Next
[COLOR=#0000FF][B]Worksheets("Sheet2").Range("A1")[/B][/COLOR].Resize(UBound(DataOut)) = DataOut
End Sub``````

HOW TO INSTALL MACROs
------------------------------------
If you are new to macros, they are easy to install and use. To install it, simply press ALT+F11 to go into the VB editor and, once there, click Insert/Module on its menu bar, then copy/paste the above code into the code window that just opened up. That's it.... you are done. To use the macro, go back to the worksheet with your data on it and press ALT+F8, select the macro name (TransposeData) from the list that appears and click the Run button. The macro will execute and perform the action(s) you asked for. If you will need to do this again in this same workbook, and if you are using XL2007 or above, make sure you save your file as an "Excel Macro-Enabled Workbook (*.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.

Thanks for the help Rick. My apologies, forgot to advise that when transposing the data, Col A to be excluded when transposing the data as these are old account numbers. The data from Col b onwards to be transposed

I tried to amend this myself, but get getting error messages

Thanks for the help Rick. My apologies, forgot to advise that when transposing the data, Col A to be excluded when transposing the data as these are old account numbers. The data from Col b onwards to be transposed
So, the mistake you made in Message #1 was to include cell A1's value, then you made a mistake in Message #3 when you "corrected" it by including Column A's values... I guess you are having "one of those days", huh?

Here is the code to handle your latest request...
Code:
``````Sub TransposeData()
Dim R As Long, C As Long, X As Long, LastRow As Long, LastCol As Long, Data As Variant, DataOut As Variant
LastRow = Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
LastCol = Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
Data = Range("A1", Cells(LastRow, LastCol))
ReDim DataOut(1 To Application.CountA(Range("B1", Cells(LastRow, LastCol))), 1 To 1)
For R = 1 To UBound(Data)
For C = 2 To UBound(Data, 2)
If Len(Cells(R, C).Value) Then
X = X + 1
DataOut(X, 1) = Cells(R, C).Value
End If
Next
Next
Worksheets("Sheet2").Range("A1").Resize(UBound(DataOut)) = DataOut
End Sub``````

Hi Rick I guess having one of those days. Got up too early this morning so brain not thinking too clearly

Thanks for your help, much appreciated

Howdy to you both,

This is very similar to Rick's, but I used the array instead of the cells, which I think Rick meant to do. I also presumed that if there is nothing in let us say, column 3 of a row, then columns 4, 5, etc. of the same row will be blank as well. Thus the Exit For.

Rich (BB code):
``````Option Explicit

Public Declare Function GetTickCount Lib "kernel32" () As Long

Sub Examplemws01()
Dim arrData       As Variant
Dim arrTransposed As Variant
Dim lLRow         As Long
Dim lLCol         As Long
Dim x             As Long
Dim y             As Long
Dim n             As Long
Dim lHack         As Long

Sheet2.Range("B:B").ClearContents '< just to start fresh

lHack = GetTickCount
With Sheet1
On Error Resume Next
lLCol = RangeFound(.Cells, SearchRowCol:=xlByColumns).Column
On Error GoTo 0

If lLCol = 0 Then MsgBox "YIKES!, no data...", vbInformation, vbNullString: Exit Sub

lLRow = RangeFound(.Cells).Row

ReDim arrTransposed(1 To Application.CountA(.Range(.Cells(1, "B"), .Cells(lLRow, lLCol))), 1 To 1)
arrData = .Range(.Cells(1, "B"), .Cells(lLRow, lLCol)).Value

For y = 1 To UBound(arrData, 1)
For x = 1 To UBound(arrData, 2)

If arrData(y, x) = vbNullString Then Exit For
n = n + 1
arrTransposed(n, 1) = arrData(y, x)

Next
Next
End With

Sheet2.Range("B1").Resize(UBound(arrTransposed, 1)).Value = arrTransposed

MsgBox "Reading array took: " & FormatNumber((GetTickCount - lHack) / 1000, 2) & " seconds."

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.Cells(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function``````

Here is what I used as to setup for testing, which hopefully mirrors your data well enough.

Rich (BB code):
``````Sub Setup()
Dim RandVal   As Long
Dim n         As Long
Dim x         As Long
Dim y         As Long
Dim arrTemp() As Long

Const UPPERBND As Long = 200000
Dim arrRandVals() As Variant
ReDim arrRandVals(1 To UPPERBND, 1 To 5)

ReDim arrTemp(1 To (UPPERBND * 5))
For n = 1 To (UPPERBND * 5)
arrTemp(n) = 33000 + n
Next
Randomize

For y = 1 To UPPERBND
For x = 1 To 5

RandVal = Int((UBound(arrTemp) - 1 + 1) * Rnd + 1)
arrRandVals(y, x) = arrTemp(RandVal)

If RandVal < UBound(arrTemp) Then
arrTemp(RandVal) = arrTemp(UBound(arrTemp))
ReDim Preserve arrTemp(1 To UBound(arrTemp) - 1)
Else
If Not UBound(arrTemp) = 1 Then ReDim Preserve arrTemp(1 To UBound(arrTemp) - 1)
End If

Next
Next

For n = 1 To UBound(arrRandVals, 1)
RandVal = Int((5 * Rnd) + 2)
For x = 5 To RandVal Step -1
arrRandVals(n, x) = vbNullString
Next

Next

With Sheet1.Range("A1:E" & UPPERBND)
.EntireColumn.ClearContents
.Value = arrRandVals
End With

End Sub``````

Hope that helps,

Mark

Last edited:
howard,

Sample raw data in worksheet Sheet1:

Excel 2007
BCDEF
13300433005330073300833009
23300333006
33324433245332473324833249
43324333246
53302433025330273302833029
6
Sheet1

After the macro (using two arrays in memory) in a new worksheet Results:

Excel 2007
A
133004
233005
333007
433008
533009
633003
733006
833244
933245
1033247
1133248
1233249
1333243
1433246
1533024
1633025
1733027
1833028
1933029
20
Results

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
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
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code:
``````Sub ReorgData()
' hiker95, 09/06/2014, ME803687
Dim w1 As Worksheet, wr As Worksheet
Dim a As Variant, o As Variant
Dim i As Long, j As Long, c As Long
Dim lr As Long, lc As Long, n As Long
Set w1 = Sheets("Sheet1")
With w1
lr = .Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
lc = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
a = .Range(.Cells(1, 2), .Cells(lr, lc))
n = Application.Count(.Range(.Cells(1, 2), .Cells(lr, lc)))
ReDim o(1 To n, 1 To 1)
End With
For i = 1 To lr
For c = 1 To lc - 1
If a(i, c) <> "" Then
j = j + 1
o(j, 1) = a(i, c)
End If
Next c
Next i
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wr = Worksheets("Results")
With wr
.UsedRange.ClearContents
.Cells(1, 1).Resize(n, 1).Value = o
.Columns(1).AutoFit
.Activate
End With
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.

Thanks for the help.

When running macro, subscript out of range and the following code highlighted

Code:
`` ReDim o(1 To n,  To 1)``

The code provided by Rick works perfectly

Replies
10
Views
326
Replies
7
Views
270
Replies
6
Views
123
Replies
8
Views
320
Replies
6
Views
234

1,196,359
Messages
6,014,804
Members
441,847
Latest member
hw407

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

### Which adblocker are you using?

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

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