# Thread: Conditional transpose Colomn to Rows (2003)

1. ## Conditional transpose Colomn to Rows (2003)

I have a sheet with 2 colums (A & [img]/forums/images/smilies/cool.gif[/img]. Column A contains names, Colum B contains a subject.
A B
John Maths
John Art
Michael History
Anne French
John English
Michael maths

I want to transpose the column so that for each unique in A all of the subjects in b will be transposed into rows..

John maths Art English
Michael maths history
Anne french

2. ## Re: Conditional transpose Colomn to Rows (2003)

Does this do what you want? I do not overwrite the current sheet but add the rearranged data on a separate sheet. You can copy and paste it where you want.

Steve

<pre>Option Explicit
Sub CondTranspose()
Dim rAll As Range
Dim rCell As Range
Dim wStart As Worksheet
Dim rList As Range
Dim wNew As Worksheet
Dim lRow As Long
Dim iCol As Integer
Dim lNextRow As Long
Dim AWF As WorksheetFunction

Set AWF = Application.WorksheetFunction

Set wStart = ActiveSheet
With wStart
Set rAll = .Range(.Range("A1"), _
.Range("a65536").End(xlUp))
End With
lNextRow = 1
With wNew
For Each rCell In rAll
Set rList = .Range(.Range("A1"), _
.Range("A65536").End(xlUp))
lRow = 0
On Error Resume Next
lRow = AWF.Match(rCell.Value, rList, 0)
On Error GoTo 0
If lRow = 0 Then
lRow = lNextRow
lNextRow = lNextRow + 1
.Cells(lRow, 1) = rCell.Value
iCol = 2
Else
iCol = 1 + .Cells(lRow, 256).End(xlToLeft).Column
End If
.Cells(lRow, iCol) = rCell.Offset(0, 1).Value
Next
End With

Set rCell = Nothing
Set rAll = Nothing
Set rList = Nothing
Set wStart = Nothing
Set wNew = Nothing
Set AWF = Nothing
End Sub</pre>

3. ## Re: Conditional transpose Colomn to Rows (2003)

This does exactly what I need.

Thanks

#### Posting Permissions

• You may not post new threads
• You may not post replies
• You may not post attachments
• You may not edit your posts
•