Transposing Question

[Coenraad]

Hi

I have a common "Rows to Columns" issue. I have the following data:
ID Surname Name Choice1 Choice2
Choice3
22 Jerry Tom Apple
Banana Orange
33 Lewis Steve Kiwi
Lemon
21 Short Jim Apple
Berry Lime
25 Kline Kevin Cherry
Melon

I have an issue with the "Choices" columns. I need the data in the following
format:

ID Surname Name Choices
22 Jerry Tom Apple
22 Jerry Tom Banana
22 Jerry Tom Orange
and so on .....

Anyone who can help? PS: the maximum number of choices are 32.

Cheers
Coenraad

 

[Sean Timmons]

Quickest way could possibly be to create 23 sets of your data, and in each
list delete 22 of the choice columns, then combine the lists.

 

[Sean Timmons]

Quickest way could possibly be to create 23 sets of your data, and in each
list delete 22 of the choice columns, then combine the lists.

 

[Sean Timmons]

Oops, dyslexia, 32 columns...

 

[Sean Timmons]

Oops, dyslexia, 32 columns...

 

[Joel]

I move the data from sheet1 to sheet 2 in the code below. The macro runs
much quicker if you don't have to delete data and insert rows in the source
sheet.

Sub Transpose()

Set SourceSht = Sheets("sheet1")
Set DestSht = Sheets("sheet2")
With DestSht
.Range("A1") = "ID"
.Range("B1") = "Surname"
.Range("C1") = "Name"
.Range("D1") = "Choises"
End With

With SourceSht
SourceRow = 2
DestRow = 2
Do While .Range("A" & SourceRow) <> ""
'set Copyrange to equal columns A - C
Set CopyRange = _
.Range("A" & SourceRow & ":C" & SourceRow)
ColCount = 4
Do While .Cells(SourceRow, ColCount) <> ""
CopyRange.Copy _
Destination:=DestSht.Range("A" & DestRow)
Choice = .Cells(SourceRow, ColCount).Value
DestSht.Range("D" & DestRow) = Choice
DestRow = DestRow + 1
ColCount = ColCount + 1
Loop
SourceRow = SourceRow + 1
Loop
End With
End Sub

 

[Joel]

I move the data from sheet1 to sheet 2 in the code below. The macro runs
much quicker if you don't have to delete data and insert rows in the source
sheet.

Sub Transpose()

Set SourceSht = Sheets("sheet1")
Set DestSht = Sheets("sheet2")
With DestSht
.Range("A1") = "ID"
.Range("B1") = "Surname"
.Range("C1") = "Name"
.Range("D1") = "Choises"
End With

With SourceSht
SourceRow = 2
DestRow = 2
Do While .Range("A" & SourceRow) <> ""
'set Copyrange to equal columns A - C
Set CopyRange = _
.Range("A" & SourceRow & ":C" & SourceRow)
ColCount = 4
Do While .Cells(SourceRow, ColCount) <> ""
CopyRange.Copy _
Destination:=DestSht.Range("A" & DestRow)
Choice = .Cells(SourceRow, ColCount).Value
DestSht.Range("D" & DestRow) = Choice
DestRow = DestRow + 1
ColCount = ColCount + 1
Loop
SourceRow = SourceRow + 1
Loop
End With
End Sub