Transposing Numbers

[howard]

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
	A	B	C	D	E
1	33004	33005	33007	33008	33009
2	33003	33006
3	33244	33245	33247	33248	33249
4	33243	33246
5	33024	33025	33027	33028	33029
6
7	33004
8	33005
9	33007
10	33008
11	33009
12	33006
13	33245
14	33247
15	33248
16	33249
17	33246
18	33025
19	33027
20	33028
21	33029
Sheet1

 

[GTO]

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

 

[howard]

Thanks for pointing this out Mark

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

Excel 2012
	A	B	C	D	E	F
1	33004	33005	33007	33008	33009
2	33003	33006
3	33244	33245	33247	33248	33249
4	33243	33246
5	33024	33025	33027	33028	33029
6
7
8
9
10
11	OutPut
12
13	33004
14	33005
15	33007
16	33008
17	33009
18	33003
19	33006
20	33244
21	33245
22	33247
23	33248
24	33249
25	33243
26	33246
27	33024
28	33025
29	33027
30	33028
31	33029
Sheet1

 

[Rick Rothstein]

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

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.

 

[howard]

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

 

[Rick Rothstein]

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

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

 

[howard]

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

 

[GTO]

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.

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.

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

 

[hiker95]

howard,

Sample raw data in worksheet Sheet1:

Excel 2007
	B	C	D	E	F
1	33004	33005	33007	33008	33009
2	33003	33006
3	33244	33245	33247	33248	33249
4	33243	33246
5	33024	33025	33027	33028	33029
6
Sheet1

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

Excel 2007
	A
1	33004
2	33005
3	33007
4	33008
5	33009
6	33003
7	33006
8	33244
9	33245
10	33247
11	33248
12	33249
13	33243
14	33246
15	33024
16	33025
17	33027
18	33028
19	33029
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
2. Open your NEW 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
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.

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.

 

[howard]

Thanks for the help.

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

 ReDim o(1 To n,  To 1)

The code provided by Rick works perfectly