CODEWITHSUNDEEP
vbaexcel
J.Doe
J.Doe

Reputation: 23

Only transpose data to a new column if it is a new group of data / excel vba

I have a column of data in excel which could potentially have data over 2000 rows. In that data there is groups of data that I would like to send to the top of a new column every time a new group is found. I've looked at the special paste option for transpose along with using a delimiter but i can only move data one column over and not to the top. I'm looking for a solution which is fast due to the amount of data that would need to be split into new columns. I appreciate the help.

Below is a table of how the data looks.

enter image description here

Below is how I would like the data to look

enter image description here

Upvotes: 0

Views: 70

Answers (2)

Shaves
Shaves

Reputation: 930

I had to do something similar. You can try also this code:

Sub Move_Data()

    Application.ScreenUpdating = False

    Dim r  As Integer
    Dim StartRow As Integer
    Dim EndRow As Integer
    Dim ColA As Integer
    Dim vLastRow As Integer
    Dim vEnd As Integer

    r = 1
    StartRow = 1
    EndRow = 1
    ColA = 4
    vEnd = 1

    vLastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row

    Do Until Cells(r, 1) <> Cells(StartRow, 1)
        DoEvents
        r = r + 1
    Loop

    vEnd = r

    Do Until r > vLastRow

        DoEvents

        StartRow = r

        Do Until Cells(r, 1) <> Cells(StartRow, 1)
            DoEvents
            r = r + 1
        Loop

        EndRow = r - 1

        Range(Cells(StartRow, 1), Cells(EndRow, 2)).Select

        Selection.Copy

        Cells(1, ColA).Select

        ActiveSheet.Paste

        ColA = ColA + 3

    Loop

    r = vEnd + 1

    Range(Cells(vEnd, 1), Cells(vLastRow, 2)).ClearContents

    Cells(1, 1).Select

    Application.ScreenUpdating = True

    MsgBox "Done"

End Sub

Upvotes: 0

Gowtham Shiva
Gowtham Shiva

Reputation: 3875

Try this simple code,

Sub splitRange()
Dim i As Long, j As Long, k As Long
Cells(1, 6) = Cells(1, 1)
Cells(1, 7) = Cells(1, 2)
j = 1
k = 6
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(i, 1) = Cells(i - 1, 1) Then
        j = j + 1
        Cells(j, k) = Cells(i, 1)
        Cells(j, k + 1) = Cells(i, 2)
    Else
        k = k + 3
        j = 1
        Cells(j, k) = Cells(i, 1)
        Cells(j, k + 1) = Cells(i, 2)
    End If
Next i
End Sub

Modify the code if you want the output in a separate sheet. I would like you to google it to learn about it.

enter image description here

Upvotes: 1

Related Questions