Moving data in excel from a column to rows based on criteria of column

Question

I have a spreadsheet that has a column of information ie:

VA221
VA222
VL911
VL911 S
VL911 M
VL911 L
VL911 XL
HF2301
HF2301 S
HF2301 M
HF2301 L
VS400
VS402

I need to move it to a new sheet based on the items in the column I have an example below.

VA221    VA222    VL911    HF2301    VS400    VS402
                  VL911 S  HF2301 S
                  VL911 M  HF2301 M
                  VL911 L  HF2301 L
                  VL911 XL

if it was just a few I would do manually but the column will be very long. If anyone can point me in the right direction.

Thanks for looking at my problem

Rick

Answer 1

Here is another VBA Macro that uses arrays and a user defined object to represent each column. The User defined object consists of a Column Header item and then a collection of items below that. It should be quite fast. It makes assumptions about the data locations that should be easily modifiable at the top of the macro.

Class Module

(rename this to cColHeaders)

---

Option Explicit
Private pColHeader As String
Private pColItem As String
Private pColItems As Collection

Private Sub Class_Initialize()
    Set pColItems = New Collection
End Sub

Public Property Get ColHeader() As String
    ColHeader = pColHeader
End Property
Public Property Let ColHeader(Value As String)
    pColHeader = Value
End Property

Public Property Get ColItem() As String
    ColItem = pColItem
End Property
Public Property Let ColItem(Value As String)
    pColItem = Value
End Property

Public Property Get ColItems() As Collection
    Set ColItems = pColItems
End Property
Function ADDColItem(Value As String)
    ColItems.Add Value
End Function

---

Regular Module

---

Option Explicit
Sub OrganizeByColumn()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes() As Variant
    Dim cCH As cColumnHeaders, colCH As Collection
    Dim I As Long, J As Long
    Dim lMaxItems As Long 'will be the maximum number of items in a column
    Dim V As Variant

'set source and results worksheets, ranges
Set wsSrc = Worksheets("sheet2")
Set wsRes = Worksheets("sheet3")
    Set rRes = wsRes.Cells(1, 1) 'start results in wsRes A1

'Get source data == assumes in Col A starting at A1
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

'Collect and organize the data
Set colCH = New Collection
For I = 1 To UBound(vSrc, 1)
    Set cCH = New cColumnHeaders
    With cCH
        .ColHeader = vSrc(I, 1)
        V = Split(.ColHeader)
        If UBound(V) = 0 Then
            colCH.Add cCH, .ColHeader
        Else
            .ColItem = vSrc(I, 1)
            .ADDColItem .ColItem
            colCH(V(0)).ADDColItem (.ColItem)
            J = colCH(V(0)).ColItems.Count
            lMaxItems = IIf(lMaxItems > J, lMaxItems, J)
        End If
    End With
Next I

'Create and populate results array
ReDim vRes(0 To lMaxItems, 1 To colCH.Count)

For I = 1 To colCH.Count
    With colCH(I)
        vRes(0, I) = .ColHeader
        For J = 1 To .ColItems.Count
            vRes(J, I) = .ColItems(J)
        Next J
    End With
Next I

'resize results range
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))

'write and format the results
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

---

Answer 2

This uses arrays and will be very quick:

Sub trnp()
Dim rngarr() As Variant
Dim oarr() As Variant
Dim rng As Range
Dim i As Long
Dim j As Long
Dim r As Long
Dim lg As Long

j = 1
r = 2
With ThisWorkbook.ActiveSheet
    Set rng = .Range(.Cells(1, 1), Cells(.Rows.Count, 1).End(xlUp))
    lg = .Evaluate("=LARGE(COUNTIF(" & rng.Address & ",""*"" & " & rng.Address & " & ""*""),1)")
    rngarr = rng.Value
    ReDim oarr(1 To lg, 1 To 1)
    oarr(1, 1) = rngarr(1, 1)
    For i = 2 To UBound(rngarr, 1)
        If InStr(rngarr(i, 1), Trim(Left(rngarr(i - 1, 1), 6))) > 0 Then
            oarr(r, j) = rngarr(i, 1)
            r = r + 1
        Else
            j = j + 1
            r = 2
            ReDim Preserve oarr(1 To lg, 1 To j)
            oarr(1, j) = rngarr(i, 1)
        End If
    Next i
    'paste back array starting in B1
    .Range("B1").Resize(UBound(oarr, 1), UBound(oarr, 2)).Value = oarr
End With

End Sub

Answer 3

Assuming the maximum characters within a value before there is a space (when applicable) is 6, you can use a combination of RTrim and Left within a While loop. See below:

Sub test()

Range("A1").Select

While ActiveCell.Value <> ""

If RTrim(Left(ActiveCell.Value, 6)) = RTrim(Left(ActiveCell.Offset(1, 0).Value, 6)) Then

    ActiveCell.Offset(1, 0).Select

Else

    ActiveCell.Offset(1, 0).Select

    If ActiveCell.Offset(1, 0).Value = "" Then

        ActiveCell.Cut
        ActiveCell.Offset(0, 1).Select
        Selection.End(xlUp).Select
        ActiveSheet.Paste
        Selection.End(xlUp).Select

    Else

        Range(Selection, Selection.End(xlDown)).Cut
        ActiveCell.Offset(0, 1).Select
        Selection.End(xlUp).Select
        ActiveSheet.Paste
        Selection.End(xlUp).Select

    End If

End If

Wend

End Sub