Consolidating a lot of rows and columns under one column

[HISO167]

Hi i was hoping you could help, this is what i have:

1	2	3	4	5
a	b	c
d	e	f	g
9

<tbody>
</tbody>

and this is what i want:

1
2
3
4
5
a
b
c
d
e
f
g
9

<tbody>
</tbody>

 

[JLGWhiz]

Sub t()
Dim lr As Long, lc As Long, c As Range
With ActiveSheet
    Columns(1).Insert
    lr = .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
    lc = .Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
    For Each c In .Range("B1:B" & lr)
        Range(c, .Cells(c.Row, Columns.Count).End(xlToLeft)).Copy
        .Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial Transpose:=True
    Next
    .Range("B1", .Cells(lr, lc)).ClearContents
End With
Application.CutCopyMode = False
End Sub

 

[JoeMo]

Here's another macro you can try that will rearrange your data in place. Assumes first data item (1) is in A1. If you have a lot of data this may be faster than the looping code in post #2.

Sub HISO()
Dim Vin As Variant, i As Long, j As Long, Vout As Variant, ct As Long
Vin = Range("A1").CurrentRegion
ReDim Vout(1 To Range("A1").CurrentRegion.Count, 1 To 1)
For i = 1 To UBound(Vin, 1)
    For j = 1 To UBound(Vin, 2)
        If Vin(i, j) <> "" Then
            ct = ct + 1
            Vout(ct, 1) = Vin(i, j)
        End If
    Next j
Next i
Application.ScreenUpdating = False
If ct > 0 Then
    Range("A1").CurrentRegion.Offset(0, 1).ClearContents
    Range("A1:A" & ct) = Vout
End If
Application.ScreenUpdating = True
End Sub