How to transpose non-uniform data in multiple columns into multiple rows?

**alexxgalaxy** · 01-03-2013, 10:32 AM

Hi

I have a large amount of non-uniform data that I need to alter from multiple columns to multiple row.
See example in Part A to Part B (Sometimes the data can spread over 20 columns for the same row). Is there any Macro that can transpose the data in the form of Part A to the form of Part B? Thanks.

Part A
Column 1,Column 2,Column 3,Column 4,Column 5,Column 6, Column 7
Team A,Jimmy,Peter,May,Mary,Ivy,Alex
Team B,Ryan,Ken,Julia
Team C,John,Noel,May,Kristyn
Team D,Mark

Part B
Column 1,Column 2,
Team A,Jimmy,
Team A,Peter
Team A,May
Team A,Mary
Team A,Ivy
Team A,Alex
Team B,Ryan
Team B,Ken
Team B,Julia
Team C,John
Team C,Noel
Team C,May
Team C,Kristyn
Team D,Mark

**JOHN H. DAVIS** · 01-03-2013, 03:41 PM

Maybe:

Sub alexxgalaxy()

Dim lr As Long
Dim rcell As Range
Dim i As Long

Application.ScreenUpdating = False

lr = Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To lr

    Range(Range("A" & i), Range("G" & i)).Copy
    
    Range("I" & Rows.Count).End(3)(2).PasteSpecial Transpose:=True
    
Next i

lr = Cells(Rows.Count, 9).End(xlUp).Row

For Each rcell In Range("I2:I" & lr)

    If Left(rcell, 4) = "Team" Then
    
        rcell.Cut rcell.Offset(, -1)
        
    End If
    
Next rcell

Range("I2").Delete xlUp

For Each rcell In Range("H2:H" & lr)

If rcell.Offset(, 1) <> "" Then

    rcell.Offset(1, 1).Select
    
        Do Until ActiveCell = ""
        
            ActiveCell.Offset(, -1).Value = rcell.Value
            
            ActiveCell.Offset(1).Select
            
        Loop
        
        End If

Next rcell

Range("H1:I" & lr).SpecialCells(xlCellTypeBlanks).Delete xlUp

Columns("A:G").Delete xlToLeft

Application.ScreenUpdating = True

End Sub

**alexxgalaxy** · 01-03-2013, 08:35 PM

Hi John

This works well for the example I gave but it didn't satisfy the situation that I mentioned "Sometimes the data can spread over 20 columns for the same row". Thanks for so much for the reply, though!!

**mike7952** · 01-03-2013, 04:28 PM

Another way

Option Explicit
Sub abcd()
 Dim a, i As Long, ii As Long, n As Long
 
 ReDim a(1 To Rows.Count, 1 To 2)
 
 With ActiveSheet
    For i = 1 To .Cells(Rows.Count, "a").End(xlUp).Row
    
       For ii = 2 To .Cells(i, Columns.Count).End(xlToLeft).Column
           n = n + 1
           a(n, 1) = .Cells(i, 1)
           a(n, 2) = .Cells(i, ii)
       Next
    Next
    .UsedRange.ClearContents
    .Cells(1).Resize(n, 2) = a
 End With
End Sub

**alexxgalaxy** · 01-03-2013, 08:40 PM

Hi Mike

This works perfect! And the syntax was a lot shorter than I expected. Also simpler, I might be able to understand how it works.

Thank you so much!!!