Transposing data based on a specific condition

[sanwar1]

Hello all,

I have a question that I am hoping you guys can help me with. I've attached some sample data below.

[TABLE="width: 132"]
<colgroup><col></colgroup><tbody>[TR]
[TD]NPI-1713912[/TD]
[/TR]
[TR]
[TD]VICTORIA JANE[/TD]
[/TR]
[TR]
[TD]VICTORIA Moses[/TD]
[/TR]
[TR]
[TD]NPI-1812001200133[/TD]
[/TR]
[TR]
[TD]James Allen[/TD]
[/TR]
[TR]
[TD]Mark Allen[/TD]
[/TR]
[TR]
[TD]NPI-786786786[/TD]
[/TR]
[TR]
[TD]Nira Patel[/TD]
[/TR]
[TR]
[TD]NPI-15612[/TD]
[/TR]
[TR]
[TD]Jesse Pinkman[/TD]
[/TR]
</tbody>[/TABLE]

I have this data in a single column. What I need is for this data to be shown like the example below.





[TABLE="width: 500"]
<tbody>[TR]
[TD]NPI-1713912[/TD]
[TD][TABLE="width: 132"]
<tbody>[TR]
[TD]VICTORIA JANE[/TD]
[/TR]
[TR]
[/TR]
</tbody>[/TABLE]

[/TD]
[TD][TABLE="width: 132"]
<tbody>[TR]
[TD]VICTORIA Moses[/TD]
[/TR]
[TR]
[/TR]
</tbody>[/TABLE]

[/TD]
[/TR]
[TR]
[TD]NPI-1812001200133[/TD]
[TD]James Allen[/TD]
[TD][TABLE="width: 132"]
<tbody>[TR]
[TD]Mark Allen[/TD]
[/TR]
[TR]
[/TR]
</tbody>[/TABLE]

[/TD]
[/TR]
[TR]
[TD]NPI-786786786[/TD]
[TD]Nira Patel[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]NPI-15612[/TD]
[TD]Jesse Pinkman

[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


As you see, I have the NPI value and then subsequent names in other columns until I hit next NPI value and put those values in next rows. There are upto 24 names under each NPI.

Any help is greatly appreciated.

 

[Andrew Poulsom]

Try:

Sub T()
    Dim r As Long
    Dim Rng As Range
    Application.ScreenUpdating = False
    With ActiveSheet.Range("A1").CurrentRegion
        For r = .Rows.Count To 1 Step -1
            If Left(.Range("A" & r).Value, 3) <> "NPI" Then
                If Rng Is Nothing Then
                    Set Rng = .Range("A" & r)
                Else
                    Set Rng = Application.Union(Rng, .Range("A" & r))
                End If
            Else
                Rng.Copy
                .Range("A" & r).Offset(0, 1).PasteSpecial Transpose:=True
                Rng.EntireRow.Delete Shift:=xlUp
                Set Rng = Nothing
            End If
        Next r
        .Parent.Cells.EntireColumn.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub